File indexing completed on 2018-03-02 18:43:03 UTC
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
d217ad1db8 Oliv*0001 #include "GAD_OPTIONS.h"
785a077159 Alis*0002 #include "PTRACERS_OPTIONS.h"
0003
0004
33e25d6b04 Jean*0005
785a077159 Alis*0006
0007
d197c88195 Jean*0008 SUBROUTINE PTRACERS_WRITE_PICKUP( permCheckPoint,
2902091e6e Jean*0009 & suff, myTime, myIter, myThid )
785a077159 Alis*0010
0011
0012
0013
0014
d217ad1db8 Oliv*0015 #include "PTRACERS_MOD.h"
785a077159 Alis*0016 IMPLICIT NONE
0017 #include "SIZE.h"
0018 #include "EEPARAMS.h"
0019 #include "PARAMS.h"
d217ad1db8 Oliv*0020 #include "GAD.h"
636477d15b Jean*0021 #include "PTRACERS_SIZE.h"
0a278985fd Jean*0022 #include "PTRACERS_PARAMS.h"
0023 #include "PTRACERS_FIELDS.h"
785a077159 Alis*0024
0025
5bc9611487 Ed H*0026
0027
0028
2902091e6e Jean*0029
5bc9611487 Ed H*0030
0031 LOGICAL permCheckPoint
785a077159 Alis*0032 CHARACTER*(*) suff
0033 _RL myTime
2902091e6e Jean*0034 INTEGER myIter
785a077159 Alis*0035 INTEGER myThid
0036
0037
0038
0039
0040 #ifdef ALLOW_PTRACERS
0041
d197c88195 Jean*0042
0043 INTEGER ILNBLNK
0044 EXTERNAL ILNBLNK
0045
785a077159 Alis*0046
804ee8c862 Jean*0047
0048
0049
0050
0051
0052
0053
0054
0055
3ab6b68cec Jean*0056 INTEGER iTracer, j, prec, lChar
804ee8c862 Jean*0057 LOGICAL glf
1706a6e971 Jean*0058 _RL timList(1)
e42d45d3cd Mart*0059 CHARACTER*(MAX_LEN_FNAM) fn
804ee8c862 Jean*0060 INTEGER listDim, nWrFlds
0061 PARAMETER( listDim = 3*PTRACERS_num )
0062 CHARACTER*(8) wrFldList(listDim)
0063 CHARACTER*(MAX_LEN_MBUF) msgBuf
3ab6b68cec Jean*0064 #ifdef PTRACERS_ALLOW_DYN_STATE
0065 INTEGER n, iRec
0066 #endif
785a077159 Alis*0067
0068
50653b81f1 Ed H*0069 #ifdef ALLOW_MNC
0070 IF ( PTRACERS_pickup_write_mnc ) THEN
5bc9611487 Ed H*0071 IF ( permCheckPoint ) THEN
d197c88195 Jean*0072 WRITE(fn,'(A)') 'pickup_ptracers'
5bc9611487 Ed H*0073 ELSE
a3218bad56 Ed H*0074 lChar = ILNBLNK(suff)
d197c88195 Jean*0075 WRITE(fn,'(2A)') 'pickup_ptracers.', suff(1:lChar)
5bc9611487 Ed H*0076 ENDIF
0077 CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
c29c5d093c Ed H*0078
5bc9611487 Ed H*0079 CALL MNC_CW_SET_UDIM(fn, 1, myThid)
0080 IF ( permCheckPoint ) THEN
0081 CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, -1, myThid)
0082 ELSE
0083 CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
0084 ENDIF
c29c5d093c Ed H*0085
0086 CALL MNC_CW_SET_UDIM(fn, 1, myThid)
5bc9611487 Ed H*0087
88f72205aa Jean*0088
5bc9611487 Ed H*0089 CALL MNC_CW_RL_W_S('D',fn,0,0,'T', myTime, myThid)
0090 CALL MNC_CW_I_W_S('I',fn,0,0,'iter', myIter, myThid)
50653b81f1 Ed H*0091 DO iTracer = 1,PTRACERS_numInUse
5bc9611487 Ed H*0092 CALL MNC_CW_RL_W('D',fn,0,0, PTRACERS_names(iTracer),
0a278985fd Jean*0093 & gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),myThid)
50653b81f1 Ed H*0094 ENDDO
5bc9611487 Ed H*0095 CALL MNC_CW_SET_UDIM(fn, 2, myThid)
0096 CALL MNC_CW_RL_W_S('D',fn,0,0,'T', myTime, myThid)
0097 CALL MNC_CW_I_W_S('I',fn,0,0,'iter', myIter, myThid)
50653b81f1 Ed H*0098 DO iTracer = 1,PTRACERS_numInUse
5bc9611487 Ed H*0099 CALL MNC_CW_RL_W('D',fn,0,0, PTRACERS_names(iTracer),
50653b81f1 Ed H*0100 & pTracer(1-OLx,1-OLy,1,1,1,iTracer),myThid)
0101 ENDDO
0102 ENDIF
d217ad1db8 Oliv*0103 IF ( useMNC .AND. PTRACERS_pickup_write_mnc ) THEN
0104 DO iTracer = 1, PTRACERS_numInUse
0105 IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
0106 WRITE(msgBuf,'(3A)')'PTRACERS_WRITE_PICKUP: MNC not yet coded',
0107 & ' for SOM advection',
0108 & ' => write bin file instead'
0109 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0110 & SQUEEZE_RIGHT, myThid)
0111 ENDIF
0112 ENDDO
0113 ENDIF
50653b81f1 Ed H*0114 #endif /* ALLOW_MNC */
d197c88195 Jean*0115
11e93ca08e Jean*0116 lChar = ILNBLNK(suff)
50653b81f1 Ed H*0117 IF ( PTRACERS_pickup_write_mdsio ) THEN
785a077159 Alis*0118
d197c88195 Jean*0119 IF ( lChar.EQ.0 ) THEN
0120 WRITE(fn,'(2A)') 'pickup_ptracers'
0121 ELSE
0122 WRITE(fn,'(2A)') 'pickup_ptracers.',suff(1:lChar)
0123 ENDIF
50653b81f1 Ed H*0124 prec = precFloat64
785a077159 Alis*0125
804ee8c862 Jean*0126
0127
0128
0129 j = 0
0130
0131 DO iTracer = 1, PTRACERS_numInUse
0132 j = j + 1
d197c88195 Jean*0133 CALL WRITE_REC_3D_RL( fn, prec, Nr,
9b39915e34 Jean*0134 & pTracer(1-OLx,1-OLy,1,1,1,iTracer),
804ee8c862 Jean*0135 & -j, myIter, myThid )
0136 IF (j.LE.listDim)
0137 & wrFldList(j) = 'pTr'//PTRACERS_ioLabel(iTracer)//' '
0138 ENDDO
0139
0140
0141 DO iTracer = 1, PTRACERS_numInUse
fc10d43a89 Jean*0142 IF ( PTRACERS_AdamsBashGtr(iTracer) .OR.
0143 & PTRACERS_AdamsBash_Tr(iTracer) ) THEN
804ee8c862 Jean*0144 j = j + 1
d197c88195 Jean*0145 CALL WRITE_REC_3D_RL( fn, prec, Nr,
9b39915e34 Jean*0146 & gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),
804ee8c862 Jean*0147 & -j, myIter, myThid )
fc10d43a89 Jean*0148 IF ( j.LE.listDim .AND. PTRACERS_AdamsBashGtr(iTracer) )
804ee8c862 Jean*0149 & wrFldList(j) = 'gPtr'//PTRACERS_ioLabel(iTracer)//'m1'
fc10d43a89 Jean*0150 IF ( j.LE.listDim .AND. PTRACERS_AdamsBash_Tr(iTracer) )
0151 & wrFldList(j) = 'pTr'//PTRACERS_ioLabel(iTracer)//'Nm1'
804ee8c862 Jean*0152 ENDIF
0153
50653b81f1 Ed H*0154 ENDDO
0155
804ee8c862 Jean*0156
0157 nWrFlds = j
0158 IF ( nWrFlds.GT.listDim ) THEN
0159 WRITE(msgBuf,'(2A,I5,A)') 'PTRACERS_WRITE_PICKUP: ',
0160 & 'trying to write ',nWrFlds,' fields'
0161 CALL PRINT_ERROR( msgBuf, myThid )
0162 WRITE(msgBuf,'(2A,I5,A)') 'PTRACERS_WRITE_PICKUP: ',
0163 & 'field-list dimension (listDim=',listDim,') too small'
0164 CALL PRINT_ERROR( msgBuf, myThid )
0165 STOP 'ABNORMAL END: S/R PTRACERS_WRITE_PICKUP (list-size Pb)'
0166 ENDIF
0167 #ifdef ALLOW_MDSIO
0168
0169 glf = globalFiles
1706a6e971 Jean*0170 timList(1) = myTime
804ee8c862 Jean*0171 CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
0172 & 0, 0, Nr, ' ',
0173 & nWrFlds, wrFldList,
ba68d2f969 Jean*0174 & 1, timList, oneRL,
804ee8c862 Jean*0175 & j, myIter, myThid )
0176 #endif /* ALLOW_MDSIO */
0177
11e93ca08e Jean*0178 ENDIF
0179
811d3e9bd3 Jean*0180 #ifdef PTRACERS_ALLOW_DYN_STATE
d217ad1db8 Oliv*0181
0182
0183 DO iTracer = 1, PTRACERS_numInUse
0184 IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
0185 IF ( lChar.EQ.0 ) THEN
0186 WRITE(fn,'(2A)') 'pickup_somTRAC',PTRACERS_ioLabel(iTracer)
0187 ELSE
0188 WRITE(fn,'(4A)') 'pickup_somTRAC',PTRACERS_ioLabel(iTracer),
0189 & '.',suff(1:lChar)
0190 ENDIF
11e93ca08e Jean*0191 _BEGIN_MASTER(myThid)
0192 WRITE(msgBuf,'(A,I4,A)')'PTRACERS_WRITE_PICKUP: iTracer =',
0193 & iTracer, ' : writing 2nd-order moments'
d217ad1db8 Oliv*0194 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
11e93ca08e Jean*0195 & SQUEEZE_RIGHT, myThid )
0196 j = ILNBLNK(fn)
0197 WRITE(msgBuf,'(A,A)') ' to file: ',fn(1:j)
0198 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0199 & SQUEEZE_RIGHT, myThid )
0200 _END_MASTER(myThid)
d217ad1db8 Oliv*0201 prec = precFloat64
0202
0203 DO n=1,nSOM
0204 iRec = n
0205 CALL WRITE_REC_3D_RL( fn, prec, Nr,
646c54e667 Jean*0206 I _Ptracers_som(:,:,:,:,:,n,iTracer),
d217ad1db8 Oliv*0207 I iRec, myIter, myThid )
0208 ENDDO
0209 ENDIF
0210 ENDDO
811d3e9bd3 Jean*0211 #endif /* PTRACERS_ALLOW_DYN_STATE */
785a077159 Alis*0212
0213 #endif /* ALLOW_PTRACERS */
0214
0215 RETURN
0216 END