** Warning **
Issuing rollback() due to DESTROY without explicit disconnect() of DBD::mysql::db handle dbname=MITgcm at /usr/local/share/lxr/lib/LXR/Common.pm line 1224.
Last-Modified: Sun, 19 Jul 2025 05:09:10 GMT
Content-Type: text/html; charset=utf-8
MITgcm/MITgcm/pkg/gmredi/gmredi_write_pickup.F
File indexing completed on 2024-02-29 06:10:26 UTC
view on github raw file Latest commit a4576c7c on 2024-02-28 22:55:11 UTC
5a6ef5c2b4 Mich* 0001 #include "GMREDI_OPTIONS.h "
0002
0003
0004
0005
0006
0007 SUBROUTINE GMREDI_WRITE_PICKUP ( permPickup ,
0008 & suff , myTime , myIter , myThid )
0009
0010
0011
0012
0013
0014 IMPLICIT NONE
0015 #include "SIZE.h "
0016 #include "EEPARAMS.h "
0017 #include "PARAMS.h "
0018 #include "GMREDI.h "
0019
0020
0021
0022
0023
0024
0025
0026 LOGICAL permPickup
0027 CHARACTER *(*) suff
0028 _RL myTime
0029 INTEGER myIter
0030 INTEGER myThid
0031
0032
0033
0034
a4576c7cde Juli* 0035 #if ( defined GM_BATES_K3D || defined GM_GEOM_VARIABLE_K )
0036
5a6ef5c2b4 Mich* 0037 INTEGER ILNBLNK
0038 EXTERNAL ILNBLNK
0039
0040
a4576c7cde Juli* 0041
0042
5a6ef5c2b4 Mich* 0043
0044
0045
0046
0047
0048
0049
a4576c7cde Juli* 0050 INTEGER n , nj , fp , lChar
5a6ef5c2b4 Mich* 0051 LOGICAL glf
0052 _RL timList (1)
0053 CHARACTER *(MAX_LEN_FNAM ) fn
0054 INTEGER listDim , nWrFlds
a4576c7cde Juli* 0055 #ifdef GM_BATES_K3D
0056 INTEGER i , j , k , bi , bj , m
0057 _RL vec (1-OLx :sNx +OLx ,1-OLy :sNy +OLy ,Nr ,nSx ,nSy )
0058 # ifdef GM_GEOM_VARIABLE_K
0059 PARAMETER ( listDim = 5+2*GM_Bates_NModes )
0060 # else
05118ac017 Jean* 0061 PARAMETER ( listDim = 2+2*GM_Bates_NModes )
a4576c7cde Juli* 0062 # endif
0063 #else /* GM_BATES_K3D */
0064 PARAMETER ( listDim = 3 )
0065 #endif /* GM_BATES_K3D */
5a6ef5c2b4 Mich* 0066 CHARACTER *(8) wrFldList (listDim )
0067 CHARACTER *(MAX_LEN_MBUF ) msgBuf
0068 CHARACTER *(8) fieldname
0069
0070
a4576c7cde Juli* 0071
5a6ef5c2b4 Mich* 0072
a4576c7cde Juli* 0073 IF ( GM_useBatesK3d .OR. GM_useGEOM ) THEN
0074
0075 lChar = ILNBLNK (suff )
0076 IF ( lChar .EQ. 0 ) THEN
0077 WRITE (fn ,'(2A)' ) 'pickup_gmredi'
0078 ELSE
0079 WRITE (fn ,'(2A)' ) 'pickup_gmredi.' ,suff (1:lChar )
0080 ENDIF
0081 fp = precFloat64
0082 n = 0
0083 nj = 0
0084
0085 #ifdef GM_BATES_K3D
0086 IF ( GM_useBatesK3d ) THEN
5a6ef5c2b4 Mich* 0087
0088
0089
0090
a4576c7cde Juli* 0091 DO bj =myByLo (myThid ),myByHi (myThid )
0092 DO bi =myBxLo (myThid ),myBxHi (myThid )
0093 DO k =1,Nr
0094 DO j =1-OLy ,sNy +OLy
0095 DO i =1-OLx ,sNx +OLx
0096 vec (i ,j ,k ,bi ,bj ) = modesC (1,i ,j ,k ,bi ,bj )
0097 ENDDO
0098 ENDDO
5a6ef5c2b4 Mich* 0099 ENDDO
0100 ENDDO
0101 ENDDO
a4576c7cde Juli* 0102 n = n + 1
0103 CALL WRITE_REC_3D_RL ( fn , fp , Nr ,
0104 & vec , -n , myIter , myThid )
0105 fieldname = 'mode01C '
0106 IF (n .LE. listDim ) wrFldList (n ) = fieldname
5a6ef5c2b4 Mich* 0107
0108
a4576c7cde Juli* 0109 DO m =1,GM_Bates_NModes
0110 DO bj =myByLo (myThid ),myByHi (myThid )
0111 DO bi =myBxLo (myThid ),myBxHi (myThid )
0112 DO k =1,Nr
0113 DO j =1-OLy ,sNy +OLy
0114 DO i =1-OLx ,sNx +OLx
0115 vec (i ,j ,k ,bi ,bj ) = modesW (m ,i ,j ,k ,bi ,bj )
0116 ENDDO
0117 ENDDO
5a6ef5c2b4 Mich* 0118 ENDDO
0119 ENDDO
0120 ENDDO
a4576c7cde Juli* 0121 n = n + 1
0122 CALL WRITE_REC_3D_RL ( fn , fp , Nr ,
0123 & vec , -n , myIter , myThid )
0124 WRITE (fieldname , '(A,I2.2,A)' ) 'mode' ,m ,'W'
0125 IF (n .LE. listDim ) wrFldList (n ) = fieldname
5a6ef5c2b4 Mich* 0126 ENDDO
0127
0128
a4576c7cde Juli* 0129 DO m =1,GM_Bates_NModes
0130 DO bj =myByLo (myThid ),myByHi (myThid )
0131 DO bi =myBxLo (myThid ),myBxHi (myThid )
0132 DO k =1,Nr
0133 DO j =1-OLy ,sNy +OLy
0134 DO i =1-OLx ,sNx +OLx
0135 vec (i ,j ,k ,bi ,bj ) = modesS (m ,i ,j ,k ,bi ,bj )
0136 ENDDO
0137 ENDDO
5a6ef5c2b4 Mich* 0138 ENDDO
0139 ENDDO
0140 ENDDO
a4576c7cde Juli* 0141 n = n + 1
0142 CALL WRITE_REC_3D_RL ( fn , fp , Nr ,
0143 & vec , -n , myIter , myThid )
0144 WRITE (fieldname , '(A,I2.2,A)' ) 'mode' ,m ,'S'
0145 IF (n .LE. listDim ) wrFldList (n ) = fieldname
5a6ef5c2b4 Mich* 0146 ENDDO
0147
0148
0149
a4576c7cde Juli* 0150 nj = -n *Nr
5a6ef5c2b4 Mich* 0151
0152
a4576c7cde Juli* 0153 n = n + 1
0154 nj = nj -1
0155 CALL WRITE_REC_3D_RL ( fn , fp , 1,
0156 & Rdef , nj , myIter , myThid )
0157 fieldname = 'Rdef '
0158 IF (n .LE. listDim ) wrFldList (n ) = fieldname
0159
0160
0161 ENDIF
0162 #endif /* GM_BATES_K3D */
0163
0164
0165
0166 #ifdef GM_GEOM_VARIABLE_K
0167 IF ( GM_useGEOM ) THEN
0168
0169 n = n + 1
0170 nj = nj -1
0171 CALL WRITE_REC_3D_RL ( fn ,fp ,1,GEOM_EKE ,nj ,myIter ,myThid )
0172 fieldname = 'GEOM_EKE'
0173 IF (n .LE. listDim ) wrFldList (n ) = fieldname
0174
0175 n = n + 1
0176 nj = nj -1
0177 CALL WRITE_REC_3D_RL ( fn ,fp ,1,GEOM_gEKE_Nm1 ,nj ,myIter ,myThid )
0178 fieldname = 'GEKE_Nm1'
0179 IF (n .LE. listDim ) wrFldList (n ) = fieldname
0180
0181
0182 ENDIF
0183 #endif /* GM_GEOM_VARIABLE_K */
0184
0185 nWrFlds = n
0186 IF ( nWrFlds .GT. listDim ) THEN
0187 WRITE (msgBuf ,'(2A,I5,A)' ) 'GMREDI_WRITE_PICKUP: ' ,
0188 & 'trying to write ' ,nWrFlds ,' fields'
0189 CALL PRINT_ERROR ( msgBuf , myThid )
0190 WRITE (msgBuf ,'(2A,I5,A)' ) 'GMREDI_WRITE_PICKUP: ' ,
0191 & 'field-list dimension (listDim=' ,listDim ,') too small'
0192 CALL PRINT_ERROR ( msgBuf , myThid )
0193 CALL ALL_PROC_DIE ( myThid )
0194 STOP 'ABNORMAL END: S/R GMREDI_WRITE_PICKUP (list-size Pb)'
0195 ENDIF
0196
5a6ef5c2b4 Mich* 0197 #ifdef ALLOW_MDSIO
0198
a4576c7cde Juli* 0199 n = 1
0200 nj = ABS(nj )
0201 IF ( nWrFlds *Nr .EQ. nj ) THEN
0202 n = Nr
0203 nj = nWrFlds
0204 ENDIF
0205 glf = globalFiles
0206 timList (1) = myTime
0207 CALL MDS_WR_METAFILES ( fn , fp , glf , .FALSE. ,
0208 & 0, 0, n , ' ' ,
0209 & nWrFlds , wrFldList ,
0210 & 1, timList , oneRL ,
0211 & nj , myIter , myThid )
5a6ef5c2b4 Mich* 0212 #endif /* ALLOW_MDSIO */
0213
a4576c7cde Juli* 0214
0215 ENDIF
0216
0217 #endif /* GM_BATES_K3D or GM_GEOM_VARIABLE_K */
5a6ef5c2b4 Mich* 0218
0219 RETURN
0220 END