pkg/mypackage/mypackage_write_pickup.F

5b141690f8 Jean*0001 #include "MYPACKAGE_OPTIONS.h"
                0002
                0003 CBOP
                0004 C !ROUTINE: MYPACKAGE_WRITE_PICKUP
                0005
                0006 C !INTERFACE: ==========================================================
                0007       SUBROUTINE MYPACKAGE_WRITE_PICKUP( permPickup,
c173f65ed6 Jean*0008      &                    suff, myTime, myIter, myThid )
5b141690f8 Jean*0009
                0010 C !DESCRIPTION:
                0011 C     Writes current state of passive tracers to a pickup file
                0012
                0013 C !USES: ===============================================================
                0014       IMPLICIT NONE
64811cb024 Jean*0015 C     == Global variables ===
5b141690f8 Jean*0016 #include "SIZE.h"
                0017 #include "EEPARAMS.h"
                0018 #include "PARAMS.h"
                0019 #include "MYPACKAGE.h"
                0020
                0021 C !INPUT PARAMETERS: ===================================================
                0022 C     permPickup      :: write a permanent pickup
                0023 C     suff            :: suffix for pickup file (eg. ckptA or 0000000010)
                0024 C     myTime          :: model time
c173f65ed6 Jean*0025 C     myIter          :: time-step number
5b141690f8 Jean*0026 C     myThid          :: thread number
                0027       LOGICAL permPickup
                0028       CHARACTER*(*) suff
                0029       _RL myTime
c173f65ed6 Jean*0030       INTEGER myIter
5b141690f8 Jean*0031       INTEGER myThid
                0032
                0033 C !OUTPUT PARAMETERS: ==================================================
                0034 C  none
                0035
68a8df71d9 Jean*0036 #if (defined MYPACKAGE_3D_STATE) || (defined MYPACKAGE_2D_STATE)
5b141690f8 Jean*0037
                0038 C     === Functions ====
                0039       INTEGER  ILNBLNK
                0040       EXTERNAL ILNBLNK
                0041
                0042 C !LOCAL VARIABLES: ====================================================
                0043 C     j           :: loop index / field number
                0044 C     nj          :: record number
                0045 C     fp          :: pickup-file precision
                0046 C     glf         :: local flag for "globalFiles"
                0047 C     fn          :: character buffer for creating filename
                0048 C     nWrFlds     :: number of fields being written
                0049 C     listDim     :: dimension of "wrFldList" local array
                0050 C     wrFldList   :: list of written fields
                0051 C     msgBuf      :: Informational/error message buffer
                0052       INTEGER j, nj, fp, lChar
                0053       LOGICAL glf
68a8df71d9 Jean*0054       _RL     timList(1)
5b141690f8 Jean*0055       CHARACTER*(MAX_LEN_FNAM) fn
                0056       INTEGER listDim, nWrFlds
                0057       PARAMETER( listDim = 12 )
                0058       CHARACTER*(8) wrFldList(listDim)
                0059       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0060 CEOP
                0061
                0062         lChar = ILNBLNK(suff)
                0063         IF ( lChar.EQ.0 ) THEN
                0064           WRITE(fn,'(2A)') 'pickup_mypackage'
                0065         ELSE
                0066           WRITE(fn,'(2A)') 'pickup_mypackage.',suff(1:lChar)
                0067         ENDIF
                0068         fp = precFloat64
                0069         j  = 0
                0070
                0071 C       Firstly, write 3-D fields as consecutive records,
                0072
                0073 #ifdef MYPACKAGE_3D_STATE
                0074 C     record number < 0 : a hack not to write meta files now:
                0075         j = j + 1
                0076         CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0077      &                        myPa_StatScal1, -j, myIter, myThid )
                0078         IF (j.LE.listDim) wrFldList(j) = 'myPaSta1'
                0079
                0080         j = j + 1
                0081         CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0082      &                        myPa_StatScal2, -j, myIter, myThid )
                0083         IF (j.LE.listDim) wrFldList(j) = 'myPaSta2'
                0084
                0085         j = j + 1
                0086         CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0087      &                        myPa_StatVelU, -j, myIter, myThid )
                0088         IF (j.LE.listDim) wrFldList(j) = 'myPaStaU'
                0089         j = j + 1
                0090         CALL WRITE_REC_3D_RL( fn, fp, Nr,
                0091      &                        myPa_StatVelV, -j, myIter, myThid )
                0092         IF (j.LE.listDim) wrFldList(j) = 'myPaStaV'
                0093 #endif /* MYPACKAGE_3D_STATE */
                0094
                0095 C-    switch to 2-D fields:
                0096         nj = -j*Nr
                0097
                0098 #ifdef MYPACKAGE_2D_STATE
                0099         j = j + 1
                0100         nj = nj-1
                0101         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0102      &                        myPa_Surf1, nj, myIter, myThid )
                0103         IF (j.LE.listDim) wrFldList(j) = 'myPaSur1'
                0104
                0105         j = j + 1
                0106         nj = nj-1
                0107         CALL WRITE_REC_3D_RL( fn, fp, 1,
                0108      &                        myPa_Surf2, nj, myIter, myThid )
                0109         IF (j.LE.listDim) wrFldList(j) = 'myPaSur2'
                0110 #endif /* MYPACKAGE_2D_STATE */
                0111
                0112 C--------------------------
                0113         nWrFlds = j
                0114         IF ( nWrFlds.GT.listDim ) THEN
                0115           WRITE(msgBuf,'(2A,I5,A)') 'MYPACKAGE_WRITE_PICKUP: ',
                0116      &     'trying to write ',nWrFlds,' fields'
                0117           CALL PRINT_ERROR( msgBuf, myThid )
                0118           WRITE(msgBuf,'(2A,I5,A)') 'MYPACKAGE_WRITE_PICKUP: ',
                0119      &     'field-list dimension (listDim=',listDim,') too small'
                0120           CALL PRINT_ERROR( msgBuf, myThid )
7610a0b85a Jean*0121           CALL ALL_PROC_DIE( myThid )
5b141690f8 Jean*0122           STOP 'ABNORMAL END: S/R MYPACKAGE_WRITE_PICKUP (list-size Pb)'
                0123         ENDIF
                0124 #ifdef ALLOW_MDSIO
                0125 C     uses this specific S/R to write (with more informations) only meta files
                0126         j  = 1
                0127         nj = ABS(nj)
                0128         IF ( nWrFlds*Nr .EQ. nj ) THEN
                0129           j  = Nr
                0130           nj = nWrFlds
                0131         ENDIF
                0132         glf  = globalFiles
68a8df71d9 Jean*0133         timList(1) = myTime
5b141690f8 Jean*0134         CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
                0135      &                         0, 0, j, ' ',
                0136      &                         nWrFlds, wrFldList,
ba68d2f969 Jean*0137      &                         1, timList, oneRL,
5b141690f8 Jean*0138      &                         nj, myIter, myThid )
                0139 #endif /* ALLOW_MDSIO */
                0140 C--------------------------
                0141
68a8df71d9 Jean*0142 #endif /* MYPACKAGE_3D_STATE or MYPACKAGE_2D_STATE */
5b141690f8 Jean*0143
                0144       RETURN
                0145       END