pkg/streamice/streamice_write_pickup.F

97c7a8be8b Jean*0001 #include "STREAMICE_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: STREAMICE_WRITE_PICKUP
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE STREAMICE_WRITE_PICKUP( permPickup,
                0008      &                    suff, myTime, myIter, myThid )
                0009
                0010 C !DESCRIPTION:
                0011 C     Writes current state of passive tracers to a pickup file
                0012
                0013 C !USES: ===============================================================
                0014       IMPLICIT NONE
                0015 #include "SIZE.h"
                0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
                0018 #include "STREAMICE.h"
                0019
                0020 C !INPUT PARAMETERS: ===================================================
                0021 C     permPickup      :: write a permanent pickup
                0022 C     suff            :: suffix for pickup file (eg. ckptA or 0000000010)
                0023 C     myTime          :: model time
                0024 C     myIter          :: time-step number
                0025 C     myThid          :: thread number
                0026       LOGICAL permPickup
                0027       CHARACTER*(*) suff
                0028       _RL myTime
                0029       INTEGER myIter
                0030       INTEGER myThid
                0031
                0032 C !OUTPUT PARAMETERS: ==================================================
                0033 C  none
                0034
                0035 #ifdef ALLOW_STREAMICE
                0036 C     === Functions ====
                0037       INTEGER  ILNBLNK
                0038       EXTERNAL ILNBLNK
                0039
                0040 C !LOCAL VARIABLES: ====================================================
                0041 C     j           :: loop index / field number
                0042 C     nj          :: record number
                0043 C     fp          :: pickup-file precision
                0044 C     glf         :: local flag for "globalFiles"
                0045 C     fn          :: character buffer for creating filename
                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     msgBuf      :: Informational/error message buffer
                0050       INTEGER j, nj, fp, lChar
                0051       LOGICAL glf
                0052       _RL     timList(1)
                0053       CHARACTER*(MAX_LEN_FNAM) fn
                0054       INTEGER listDim, nWrFlds
                0055       PARAMETER( listDim = 12 )
                0056       CHARACTER*(8) wrFldList(listDim)
                0057       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0058 CEOP
                0059
                0060         lChar = ILNBLNK(suff)
                0061         IF ( lChar.EQ.0 ) THEN
                0062           WRITE(fn,'(2A)') 'pickup_streamice'
                0063         ELSE
                0064           WRITE(fn,'(2A)') 'pickup_streamice.',suff(1:lChar)
                0065         ENDIF
                0066         fp = precFloat64
                0067         j  = 0
                0068
                0069 C       Firstly, write 3-D fields as consecutive records,
                0070
                0071 #ifdef STREAMICE_HYBRID_STRESS
                0072 C     record number < 0 : a hack not to write meta files now:
                0073         j = j + 1
7360cc2681 Jean*0074         CALL WRITE_REC_3D_RL( fn, fp, Nr, visc_streamice_full,
                0075      &                        -j, myIter, myThid )
97c7a8be8b Jean*0076         IF (j.LE.listDim) wrFldList(j) = 'visc3d  '
                0077 #endif /* STREAMICE_HYBRID_STRESS */
                0078
                0079 C-    switch to 2-D fields:
                0080         nj = -j*Nr
                0081
                0082         j = j + 1
                0083         nj = nj-1
7360cc2681 Jean*0084         CALL WRITE_REC_3D_RL( fn, fp, 1, area_shelf_streamice,
                0085      &                        nj, myIter, myThid )
97c7a8be8b Jean*0086         IF (j.LE.listDim) wrFldList(j) = 'SI_area '
                0087
eaf63fbcc2 Dani*0088         j = j + 1
                0089         nj = nj-1
7360cc2681 Jean*0090         CALL WRITE_REC_3D_RS( fn, fp, 1, STREAMICE_hmask,
                0091      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0092         IF (j.LE.listDim) wrFldList(j) = 'SI_hmask'
                0093
                0094         j = j + 1
                0095         nj = nj-1
7360cc2681 Jean*0096         CALL WRITE_REC_3D_RL( fn, fp, 1, U_streamice,
                0097      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0098         IF (j.LE.listDim) wrFldList(j) = 'SI_uvel '
                0099
                0100         j = j + 1
                0101         nj = nj-1
7360cc2681 Jean*0102         CALL WRITE_REC_3D_RL( fn, fp, 1, V_streamice,
                0103      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0104         IF (j.LE.listDim) wrFldList(j) = 'SI_vvel '
                0105
                0106         j = j + 1
                0107         nj = nj-1
7360cc2681 Jean*0108         CALL WRITE_REC_3D_RL( fn, fp, 1, H_streamice,
                0109      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0110         IF (j.LE.listDim) wrFldList(j) = 'SI_thick'
7360cc2681 Jean*0111
eaf63fbcc2 Dani*0112         j = j + 1
                0113         nj = nj-1
7360cc2681 Jean*0114         CALL WRITE_REC_3D_RL( fn, fp, 1, tau_beta_eff_streamice,
                0115      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0116         IF (j.LE.listDim) wrFldList(j) = 'SI_betaF'
                0117
                0118         j = j + 1
                0119         nj = nj-1
7360cc2681 Jean*0120         CALL WRITE_REC_3D_RL( fn, fp, 1, visc_streamice,
                0121      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0122         IF (j.LE.listDim) wrFldList(j) = 'SI_visc '
                0123
                0124 #ifdef STREAMICE_HYBRID_STRESS
                0125         j = j + 1
                0126         nj = nj-1
7360cc2681 Jean*0127         CALL WRITE_REC_3D_RL( fn, fp, 1, streamice_taubx,
                0128      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0129         IF (j.LE.listDim) wrFldList(j) = 'SI_taubx'
                0130
                0131         j = j + 1
                0132         nj = nj-1
7360cc2681 Jean*0133         CALL WRITE_REC_3D_RL( fn, fp, 1, streamice_tauby,
                0134      &                        nj, myIter, myThid )
eaf63fbcc2 Dani*0135         IF (j.LE.listDim) wrFldList(j) = 'SI_tauby'
                0136 #endif
                0137
97c7a8be8b Jean*0138 c       j = j + 1
                0139 c       nj = nj-1
7360cc2681 Jean*0140 c       CALL WRITE_REC_3D_RL( fn, fp, 1, myPa_Surf2,
                0141 c    &                        nj, myIter, myThid )
97c7a8be8b Jean*0142 c       IF (j.LE.listDim) wrFldList(j) = 'myPaSur2'
                0143
                0144 C--------------------------
                0145         nWrFlds = j
                0146         IF ( nWrFlds.GT.listDim ) THEN
                0147           WRITE(msgBuf,'(2A,I5,A)') 'STREAMICE_WRITE_PICKUP: ',
                0148      &     'trying to write ',nWrFlds,' fields'
                0149           CALL PRINT_ERROR( msgBuf, myThid )
                0150           WRITE(msgBuf,'(2A,I5,A)') 'STREAMICE_WRITE_PICKUP: ',
                0151      &     'field-list dimension (listDim=',listDim,') too small'
                0152           CALL PRINT_ERROR( msgBuf, myThid )
                0153           CALL ALL_PROC_DIE( myThid )
                0154           STOP 'ABNORMAL END: S/R STREAMICE_WRITE_PICKUP (list-size Pb)'
                0155         ENDIF
                0156 #ifdef ALLOW_MDSIO
                0157 C     uses this specific S/R to write (with more informations) only meta files
                0158         j  = 1
                0159         nj = ABS(nj)
                0160         IF ( nWrFlds*Nr .EQ. nj ) THEN
                0161           j  = Nr
                0162           nj = nWrFlds
                0163         ENDIF
                0164         glf  = globalFiles
                0165         timList(1) = myTime
                0166         CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0167      &                         0, 0, j, ' ',
                0168      &                         nWrFlds, wrFldList,
                0169      &                         1, timList, oneRL,
                0170      &                         nj, myIter, myThid )
                0171 #endif /* ALLOW_MDSIO */
                0172 C--------------------------
                0173
                0174 #endif /* ALLOW_STREAMICE */
                0175
                0176       RETURN
                0177       END