pkg/seaice/seaice_write_pickup.F

ae125ba74b Jean*0001 #include "SEAICE_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: SEAICE_WRITE_PICKUP
                0005 C     !INTERFACE:
                0006       SUBROUTINE SEAICE_WRITE_PICKUP ( permPickup, suff,
                0007      I                                 myTime, myIter, myThid )
                0008
                0009 C     !DESCRIPTION: \bv
                0010 C     *==========================================================*
                0011 C     | SUBROUTINE SEAICE_WRITE_PICKUP
                0012 C     | o Write sea ice pickup file for restarting.
                0013 C     *==========================================================*
                0014 C     \ev
                0015
                0016 C     !USES:
                0017       IMPLICIT NONE
                0018
                0019 C     == Global variables ===
                0020 #include "SIZE.h"
                0021 #include "EEPARAMS.h"
                0022 #include "PARAMS.h"
ccaa3c61f4 Patr*0023 #include "SEAICE_SIZE.h"
ae125ba74b Jean*0024 #include "SEAICE_PARAMS.h"
                0025 #include "SEAICE.h"
ccaa3c61f4 Patr*0026 #include "SEAICE_TRACER.h"
ae125ba74b Jean*0027
                0028 C     !INPUT/OUTPUT PARAMETERS:
                0029 C     == Routine arguments ==
                0030 C     permPickup :: write a permanent pickup
                0031 C     suff    :: suffix for pickup file (eg. ckptA or 0000000010)
                0032 C     myTime  :: Current time in simulation
                0033 C     myIter  :: Current iteration number in simulation
                0034 C     myThid  :: My Thread Id number
                0035       LOGICAL permPickup
                0036       CHARACTER*(*) suff
                0037       _RL     myTime
                0038       INTEGER myIter
                0039       INTEGER myThid
                0040
                0041 C     !LOCAL VARIABLES:
                0042 C     == Local variables ==
                0043 C     fp          :: pickup-file precision ( precFloat64 )
                0044 C     glf         :: local flag for "globalFiles"
                0045 C     fn          :: Temp. for building file name.
                0046 C     nWrFlds     :: number of fields being written
                0047 C     listDim     :: dimension of "wrFldList" local array
                0048 C     wrFldList   :: list of written fields
                0049 C     j           :: loop index / field number
                0050 C     nj          :: record number
                0051 C     msgBuf      :: Informational/error message buffer
                0052       INTEGER fp
                0053       LOGICAL  glf
1706a6e971 Jean*0054       _RL     timList(1)
ae125ba74b Jean*0055       CHARACTER*(MAX_LEN_FNAM) fn
                0056       INTEGER listDim, nWrFlds
                0057       PARAMETER( listDim = 20 )
edfdf5fa1d Jean*0058       CHARACTER*(8) wrFldList(listDim)
                0059       INTEGER j, nj
ae125ba74b Jean*0060       CHARACTER*(MAX_LEN_MBUF) msgBuf
e54fe3e1f9 Gael*0061 #ifdef ALLOW_SITRACER
edfdf5fa1d Jean*0062       CHARACTER*(8) fldName
78c1ea7129 Patr*0063       INTEGER iTrac
edfdf5fa1d Jean*0064 #endif
ae125ba74b Jean*0065 CEOP
                0066
                0067 C--   Write model fields
                0068       WRITE(fn,'(A,A)') 'pickup_seaice.',suff
                0069
                0070 c     IF ( seaice_pickup_write_mdsio ) THEN
                0071
                0072        fp = precFloat64
                0073        j = 0
                0074        nj = 0
                0075 C     record number < 0 : a hack not to write meta files now:
                0076
                0077 C--   write Sea-Ice Thermodynamics State variables, starting with 3-D fields:
                0078        IF ( .NOT.useThSIce ) THEN
e2bce35691 Jean*0079
                0080 #ifdef SEAICE_ITD
                0081
                0082         j = j + 1
                0083         CALL WRITE_REC_3D_RL( fn,fp, nITD, TICES,   -j, myIter,myThid )
                0084         IF (j.LE.listDim) wrFldList(j) = 'siTICES '
                0085         j = j + 1
                0086         CALL WRITE_REC_3D_RL( fn,fp, nITD, AREAITD, -j, myIter,myThid )
                0087         IF (j.LE.listDim) wrFldList(j) = 'siAREAn '
                0088         j = j + 1
                0089         CALL WRITE_REC_3D_RL( fn,fp, nITD, HEFFITD, -j, myIter,myThid )
                0090         IF (j.LE.listDim) wrFldList(j) = 'siHEFFn '
                0091         j = j + 1
                0092         CALL WRITE_REC_3D_RL( fn,fp, nITD, HSNOWITD,-j, myIter,myThid )
                0093         IF (j.LE.listDim) wrFldList(j) = 'siHSNOWn'
                0094 C-    switch to 2-D fields:
                0095         nj = -j*nITD
                0096
                0097 #else /* SEAICE_ITD */
                0098
3d682e2e14 Torg*0099         j = j + 1
                0100         nj = nj-1
f5282c5b03 Gael*0101         IF (SEAICE_multDim.GT.1) THEN
f913c5a485 Mart*0102          CALL WRITE_REC_3D_RL(fn,fp,nITD,TICES, nj, myIter, myThid )
f5282c5b03 Gael*0103          IF (j.LE.listDim) wrFldList(j) = 'siTICES '
ae125ba74b Jean*0104 C-    switch to 2-D fields:
f913c5a485 Mart*0105 c         nj = nj*nITD
                0106          nj = nj-nITD+1
f5282c5b03 Gael*0107         ELSE
f913c5a485 Mart*0108          CALL WRITE_REC_LEV_RL( fn, fp, nITD, 1, 1, TICES,
2d5ef26c04 Jean*0109      I                          nj, myIter, myThid )
f5282c5b03 Gael*0110          IF (j.LE.listDim) wrFldList(j) = 'siTICE  '
                0111         ENDIF
ae125ba74b Jean*0112
                0113 C---  continue to write 2-D fields:
                0114         j = j + 1
3d682e2e14 Torg*0115         nj = nj-1
772590b63c Mart*0116         CALL WRITE_REC_3D_RL( fn, fp,  1, AREA , nj, myIter, myThid )
ae125ba74b Jean*0117         IF (j.LE.listDim) wrFldList(j) = 'siAREA  '
                0118         j = j + 1
3d682e2e14 Torg*0119         nj = nj-1
772590b63c Mart*0120         CALL WRITE_REC_3D_RL( fn, fp,  1, HEFF , nj, myIter, myThid )
ae125ba74b Jean*0121         IF (j.LE.listDim) wrFldList(j) = 'siHEFF  '
                0122         j = j + 1
3d682e2e14 Torg*0123         nj = nj-1
ae125ba74b Jean*0124         CALL WRITE_REC_3D_RL( fn, fp,  1, HSNOW , nj, myIter, myThid )
                0125         IF (j.LE.listDim) wrFldList(j) = 'siHSNOW '
e2bce35691 Jean*0126
                0127 #endif /* SEAICE_ITD */
                0128
a98c4b8072 Ian *0129 #ifdef SEAICE_VARIABLE_SALINITY
ae125ba74b Jean*0130         j = j + 1
                0131         nj = nj-1
                0132         CALL WRITE_REC_3D_RL( fn, fp,  1, HSALT , nj, myIter, myThid )
                0133         IF (j.LE.listDim) wrFldList(j) = 'siHSALT '
                0134 #endif
78c1ea7129 Patr*0135 #ifdef ALLOW_SITRACER
38cfb58d85 Gael*0136          DO iTrac = 1, SItrNumInUse
78c1ea7129 Patr*0137           WRITE(fldName,'(A6,I2.2)') 'siTrac', iTrac
c284306958 Patr*0138           j = j + 1
                0139           nj = nj-1
                0140           CALL WRITE_REC_3D_RL( fn, fp,  1,
ba68d2f969 Jean*0141      &         SItracer(1-OLx,1-OLy,1,1,iTrac),
c284306958 Patr*0142      &         nj, myIter, myThid )
                0143           IF (j.LE.listDim) wrFldList(j) = fldName
78c1ea7129 Patr*0144          ENDDO
                0145 #endif
ae125ba74b Jean*0146        ENDIF
                0147
                0148 C--    write Sea-Ice Dynamics variables (all 2-D fields):
                0149        j = j + 1
                0150        nj = nj-1
772590b63c Mart*0151        CALL WRITE_REC_3D_RL( fn, fp,  1, UICE , nj, myIter, myThid )
ae125ba74b Jean*0152        IF (j.LE.listDim)  wrFldList(j) = 'siUICE  '
                0153
                0154        j = j + 1
                0155        nj = nj-1
772590b63c Mart*0156        CALL WRITE_REC_3D_RL( fn, fp,  1, VICE , nj, myIter, myThid )
ae125ba74b Jean*0157        IF (j.LE.listDim)  wrFldList(j) = 'siVICE  '
                0158
e501eee760 Mart*0159        IF ( SEAICEuseBDF2 ) THEN
6cbc659de0 Mart*0160         j = j + 1
                0161         nj = nj-1
                0162         CALL WRITE_REC_3D_RL( fn, fp,  1, uIceNm1 , nj, myIter, myThid )
                0163         IF (j.LE.listDim)  wrFldList(j) = 'siUicNm1'
                0164
                0165         j = j + 1
                0166         nj = nj-1
                0167         CALL WRITE_REC_3D_RL( fn, fp,  1, vIceNm1 , nj, myIter, myThid )
                0168         IF (j.LE.listDim)  wrFldList(j) = 'siVicNm1'
                0169        ENDIF
ae125ba74b Jean*0170 #if (defined(SEAICE_CGRID) && defined(SEAICE_ALLOW_EVP))
                0171        IF ( SEAICEuseEVP ) THEN
                0172         j = j + 1
                0173         nj = nj-1
                0174         CALL WRITE_REC_3D_RL( fn, fp,  1, seaice_sigma1,
                0175      &                                            nj, myIter, myThid )
                0176         IF (j.LE.listDim) wrFldList(j) = 'siSigm1 '
                0177
                0178         j = j + 1
                0179         nj = nj-1
                0180         CALL WRITE_REC_3D_RL( fn, fp,  1, seaice_sigma2,
                0181      &                                            nj, myIter, myThid )
                0182         IF (j.LE.listDim) wrFldList(j) = 'siSigm2 '
                0183
                0184         j = j + 1
                0185         nj = nj-1
                0186         CALL WRITE_REC_3D_RL( fn, fp,  1, seaice_sigma12,
                0187      &                                            nj, myIter, myThid )
                0188         IF (j.LE.listDim) wrFldList(j) = 'siSigm12'
                0189        ENDIF
                0190 #endif /* SEAICE_ALLOW_EVP */
                0191
                0192        nWrFlds = j
                0193        IF ( nWrFlds.GT.listDim ) THEN
                0194          WRITE(msgBuf,'(2A,I5,A)') 'WRITE_SEAICE_PICKUP: ',
                0195      &     'trying to write ',nWrFlds,' fields'
                0196          CALL PRINT_ERROR( msgBuf, myThid )
                0197          WRITE(msgBuf,'(2A,I5,A)') 'WRITE_SEAICE_PICKUP: ',
                0198      &     'field-list dimension (listDim=',listDim,') too small'
                0199          CALL PRINT_ERROR( msgBuf, myThid )
                0200          STOP 'ABNORMAL END: S/R WRITE_SEAICE_PICKUP (list-size Pb)'
                0201        ENDIF
78c1ea7129 Patr*0202
ae125ba74b Jean*0203 #ifdef ALLOW_MDSIO
                0204 C     uses this specific S/R to write (with more informations) only meta files
                0205        nj = ABS(nj)
                0206        glf  = globalFiles
1706a6e971 Jean*0207        timList(1) = myTime
ae125ba74b Jean*0208        CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0209      &                         0, 0, 1, ' ',
                0210      &                         nWrFlds, wrFldList,
ba68d2f969 Jean*0211      &                         1, timList, oneRL,
ae125ba74b Jean*0212      &                         nj, myIter, myThid )
78c1ea7129 Patr*0213 C
ae125ba74b Jean*0214 #endif /* ALLOW_MDSIO */
                0215 C--------------------------
                0216 c     ENDIF
                0217
                0218       RETURN
                0219       END