| 1 |
! $Header: $ |
| 2 |
! $Name: $ |
| 3 |
|
| 4 |
MODULE SRDIAGS_MANAGER |
| 5 |
! |
| 6 |
! SR_DIAGS provides sub-region diagnostic accumulation for logically |
| 7 |
! rectangular meshes. |
| 8 |
! In MITgcm it is called from within DIAGS. |
| 9 |
! SR_DIAGS allocates buffers for saving sub-region data for particular fields |
| 10 |
! These buffers need to be allocated by the threads that will write to |
| 11 |
! them. Buffers are visible for read access across threads to allow for sinlge |
| 12 |
! threade I/O and communication - yucky..... |
| 13 |
! |
| 14 |
USE SRDIAGS_TYPES |
| 15 |
|
| 16 |
INTERFACE SRDIAG_FILL |
| 17 |
MODULE PROCEDURE SRDIAG_FILL_R8XYZ |
| 18 |
END INTERFACE |
| 19 |
|
| 20 |
CONTAINS |
| 21 |
|
| 22 |
SUBROUTINE SRDIAG_ADD_FCODE( fCode, offset, dAttr, diagVar, |
| 23 |
I mFactor, |
| 24 |
& myThid ) |
| 25 |
! |
| 26 |
! Add a field code to a SRDIAGS set |
| 27 |
! Indices for this field code will use offset "offset". |
| 28 |
! |
| 29 |
! == Routine arguments == |
| 30 |
CHARACTER*(*) fCode |
| 31 |
INTEGER offset(3) |
| 32 |
CHARACTER*(*) dAttr |
| 33 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 34 |
INTEGER myThid, nCodes |
| 35 |
REAL*8 mFactor |
| 36 |
|
| 37 |
! == Local variables == |
| 38 |
TYPE(SRDIAG_FCODE), POINTER :: tempCL(:) |
| 39 |
|
| 40 |
! |
| 41 |
! Expand list |
| 42 |
! |
| 43 |
diagVar%nCodes = diagVar%nCodes+1 |
| 44 |
nCodes = diagVar%nCodes |
| 45 |
IF ( nCodes .EQ. 1 ) THEN |
| 46 |
ALLOCATE( diagVar%cList(1) ) |
| 47 |
ELSE |
| 48 |
ALLOCATE( tempCL(nCodes-1) ) |
| 49 |
tempCL = diagVar%cList |
| 50 |
DEALLOCATE( diagVar%cList ) |
| 51 |
ALLOCATE( diagVar%cList(nCodes) ) |
| 52 |
diagVar%cList(1:nCodes-1) = tempCL |
| 53 |
DEALLOCATE( tempCL ) |
| 54 |
ENDIF |
| 55 |
! |
| 56 |
! Add entry |
| 57 |
! |
| 58 |
diagVar%cList(nCodes)%fCode = fCode |
| 59 |
diagVar%cList(nCodes)%dAttr = dAttr |
| 60 |
diagVar%cList(nCodes)%iOffset = offset(1) |
| 61 |
diagVar%cList(nCodes)%jOffset = offset(2) |
| 62 |
diagVar%cList(nCodes)%kOffset = offset(3) |
| 63 |
diagVar%cList(nCodes)%mFactor = mFactor |
| 64 |
|
| 65 |
RETURN |
| 66 |
END SUBROUTINE |
| 67 |
|
| 68 |
SUBROUTINE SRDIAG_ADD_REGION( |
| 69 |
I myLoI, myLoJ, myLoK, |
| 70 |
I myNI, myNJ, myNK, |
| 71 |
I iLo, jLo, kLo, |
| 72 |
I nI, nJ, nK, |
| 73 |
U diagVar, |
| 74 |
I myThid ) |
| 75 |
! |
| 76 |
! Add a simple region to a DIAG type variable |
| 77 |
! |
| 78 |
! Lots still to be done..... |
| 79 |
! DIAGS specification file must have been read before SR_DIAG_CREATE is called. |
| 80 |
! |
| 81 |
! Here we create masks for each of the index sets specified in the sub-region set. |
| 82 |
! These masks can be do loop regions, scatters, broken lines etc... |
| 83 |
|
| 84 |
! o do loop regions are specified in the input using [start:stride:end] or [v1 v2 v3] sets |
| 85 |
! of values. |
| 86 |
! o not sure how we specify scatters and broken lines in input yet. probably using |
| 87 |
! { } for point lists instead of [ ] for loops. |
| 88 |
! Note - { } point lists for a single region specification have to all be the same size. |
| 89 |
! - e.g. |
| 90 |
! {1 3 5}{7 4 8}[1 2] would give |
| 91 |
! for k=1:2 |
| 92 |
! for lp=1:3 |
| 93 |
! pt=[il(1), jl(1), k] |
| 94 |
! end |
| 95 |
! end |
| 96 |
! - whereas |
| 97 |
! [1 3 5][7 4 8][1 2] would give |
| 98 |
! for k=1:2 |
| 99 |
! for j=[7 4 8] |
| 100 |
! for i=[1 3 5] |
| 101 |
! pt=[i, j, k] |
| 102 |
! end |
| 103 |
! end |
| 104 |
! end |
| 105 |
! |
| 106 |
|
| 107 |
! -- Routine arguments -- |
| 108 |
! myLoI :: Offset from origin for this part of the mask. |
| 109 |
! myLoJ :: Offset from origin for this part of the mask. |
| 110 |
! myLoK :: Offset from origin for this part of the mask. |
| 111 |
! myNi :: Number cells in I for this part of the mask. |
| 112 |
! myNj :: Number cells in J for this part of the mask. |
| 113 |
! myNk :: Number cells in K for this part of the mask. |
| 114 |
! iLo :: Base coordinate in I for subregion. |
| 115 |
! jLo :: Base coordinate in J for subregion. |
| 116 |
! kLo :: Base coordinate in K for subregion. |
| 117 |
! nI :: Number of cells in I for subregion. |
| 118 |
! nJ :: Number of cells in J for subregion. |
| 119 |
! nK :: Number of cells in K for subregion. |
| 120 |
! diagVar :: Diagnostics structure to add region to. |
| 121 |
! myThid :: Id number of the thread making this call. |
| 122 |
INTEGER myLoI |
| 123 |
INTEGER myLoJ |
| 124 |
INTEGER myLoK |
| 125 |
INTEGER myNi |
| 126 |
INTEGER myNj |
| 127 |
INTEGER myNk |
| 128 |
INTEGER iLo |
| 129 |
INTEGER jLo |
| 130 |
INTEGER kLo |
| 131 |
INTEGER nI |
| 132 |
INTEGER nJ |
| 133 |
INTEGER nK |
| 134 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 135 |
INTEGER myThid |
| 136 |
|
| 137 |
! -- Local variables -- |
| 138 |
! |
| 139 |
TYPE(SRDIAG_MASK), POINTER :: tempML(:) |
| 140 |
INTEGER :: I, J, K |
| 141 |
INTEGER :: nPS |
| 142 |
! |
| 143 |
! Expand list |
| 144 |
diagVar%nPointSets = diagVar%nPointSets+1 |
| 145 |
nPS = diagVar%nPointSets |
| 146 |
IF ( nPS .EQ. 1 ) THEN |
| 147 |
ALLOCATE( diagVar%mList(1) ) |
| 148 |
ELSE |
| 149 |
ALLOCATE( tempML(nPS-1) ) |
| 150 |
tempML = diagVar%mList |
| 151 |
DEALLOCATE(diagVar%mList) |
| 152 |
ALLOCATE( diagVar%mList(nPS) ) |
| 153 |
diagVar%mList(1:nPS-1)=tempML |
| 154 |
DEALLOCATE(tempML) |
| 155 |
ENDIF |
| 156 |
! |
| 157 |
! Now add new diag |
| 158 |
! o create mask for this instance |
| 159 |
! for now this mask has size of the region owned |
| 160 |
! by the instance. |
| 161 |
ALLOCATE( |
| 162 |
& diagVar%mList(nPS)%mask( |
| 163 |
& myLoI:myLoI+myNI-1, |
| 164 |
& myLoJ:myLoJ+myNJ-1, |
| 165 |
& myLoK:myLoK+myNK-1 |
| 166 |
& ) |
| 167 |
&) |
| 168 |
diagVar%mList(nPS)%mask = .FALSE. |
| 169 |
DO K=myLoK,myLoK+myNK-1 |
| 170 |
IF ( K .GE. kLo .AND. K .LE. kLo+nK-1 ) THEN |
| 171 |
DO J=myLoJ,myLoJ+myNJ-1 |
| 172 |
IF ( J .GE. jLo .AND. J .LE. jLo+nJ-1 ) THEN |
| 173 |
DO I=myLoI,myLoI+myNI-1 |
| 174 |
IF ( I .GE. iLo .AND. I .LE. iLo+nI-1 ) THEN |
| 175 |
diagVar%mList(nPS)%mask(I,J,K) = .TRUE. |
| 176 |
! PRINT *, ' HELLO -1', myThid,I,J,K |
| 177 |
ENDIF |
| 178 |
ENDDO |
| 179 |
ENDIF |
| 180 |
ENDDO |
| 181 |
ENDIF |
| 182 |
ENDDO |
| 183 |
diagVar%mList(nPS)%nX = nI |
| 184 |
diagVar%mList(nPS)%nY = nJ |
| 185 |
diagVar%mList(nPS)%nR = nK |
| 186 |
diagVar%mList(nPS)%iLo = iLo |
| 187 |
diagVar%mList(nPS)%jLo = jLo |
| 188 |
diagVar%mList(nPS)%kLo = kLo |
| 189 |
|
| 190 |
RETURN |
| 191 |
END SUBROUTINE |
| 192 |
|
| 193 |
SUBROUTINE SRDIAG_CREATE( diagVar, aveFreq, outName, myThid ) |
| 194 |
! |
| 195 |
! Create a sub-region diagnostics spec object |
| 196 |
! |
| 197 |
! == Routine arguments == |
| 198 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 199 |
REAL*8 :: aveFreq |
| 200 |
CHARACTER*(*) :: outName |
| 201 |
INTEGER myThid |
| 202 |
|
| 203 |
! == Local variables == |
| 204 |
INTEGER iUnit |
| 205 |
|
| 206 |
ALLOCATE( diagVar ) |
| 207 |
diagVar%nPointSets = 0 |
| 208 |
diagVar%nCodes = 0 |
| 209 |
diagVar%aPeriod = aveFreq |
| 210 |
WRITE( diagVar%outName, '(A,A,I4.4)' ) TRIM(outName),'.',myThid |
| 211 |
NULLIFY(diagVar%bList) |
| 212 |
NULLIFY(diagVar%cList) |
| 213 |
|
| 214 |
! Clear the output file |
| 215 |
CALL MDSFINDUNIT( iUnit, myThid ) |
| 216 |
OPEN(unit=iUnit,file=TRIM(diagVar%outName), |
| 217 |
& FORM='unformatted',STATUS='NEW') |
| 218 |
CLOSE(iUnit) |
| 219 |
|
| 220 |
RETURN |
| 221 |
END SUBROUTINE |
| 222 |
|
| 223 |
SUBROUTINE SRDIAG_FILL_R8XYZ( fld, alpha, fCode, diagVar, myThid ) |
| 224 |
! == Routine arguments == |
| 225 |
REAL*8 :: fld(:,:,:) |
| 226 |
REAL*8 :: alpha |
| 227 |
CHARACTER*(*) :: fCode |
| 228 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 229 |
INTEGER :: myThid |
| 230 |
|
| 231 |
! == Local variables == |
| 232 |
INTEGER :: nRegs, nBufs |
| 233 |
INTEGER :: I, J, K, rC, thisCodeRank, NR |
| 234 |
INTEGER :: iB |
| 235 |
TYPE(SRDIAG_BUFFER), POINTER :: myBufs(:) |
| 236 |
TYPE(SRDIAG_BUFFER), POINTER :: myBuf |
| 237 |
INTEGER :: iLoFld, jLoFld, kLoFld |
| 238 |
INTEGER :: iHiFld, jHiFld, kHiFld |
| 239 |
INTEGER :: iLo, iHi, jLo, jHi, kLo, kHi |
| 240 |
INTEGER :: iLoMsk, iHiMsk |
| 241 |
INTEGER :: jLoMsk, jHiMsk |
| 242 |
INTEGER :: kLoMsk, kHiMsk |
| 243 |
INTEGER :: iFld, jFld, kFld |
| 244 |
! |
| 245 |
! PRINT *, 'HELLO 1' |
| 246 |
|
| 247 |
! Determine the field code rank for the field code fCode within subregion diagVar. |
| 248 |
CALL SRDIAG_GET_FIELD_CODE_RANK( |
| 249 |
I fCode, diagVar, |
| 250 |
O thisCodeRank, |
| 251 |
I myThid ) |
| 252 |
IF ( thisCodeRank .EQ. 0 ) RETURN |
| 253 |
! PRINT *, 'HELLO 2' |
| 254 |
|
| 255 |
! Look for an existing buffer for this code (for each region in turn |
| 256 |
! so that we find out if there are regions with no buffers). |
| 257 |
! If buffer is found we will use that buffer, otherwise we will create it. |
| 258 |
nRegs = diagVar%nPointSets |
| 259 |
iLoFld = LBOUND(fld,1)+diagVar%cList(thisCodeRank)%iOffset |
| 260 |
jLoFld = LBOUND(fld,2)+diagVar%cList(thisCodeRank)%jOffset |
| 261 |
kLoFld = LBOUND(fld,3)+diagVar%cList(thisCodeRank)%kOffset |
| 262 |
iHiFld = UBOUND(fld,1)+diagVar%cList(thisCodeRank)%iOffset |
| 263 |
jHiFld = UBOUND(fld,2)+diagVar%cList(thisCodeRank)%jOffset |
| 264 |
kHiFld = UBOUND(fld,3)+diagVar%cList(thisCodeRank)%kOffset |
| 265 |
! PRINT *, 'HELLO 3', iLoFld, iHiFld, TRIM(fCode) |
| 266 |
! PRINT *, 'HELLO 3', jLoFld, jHiFld, TRIM(fCode) |
| 267 |
! PRINT *, 'HELLO 3', kLoFld, kHiFld, TRIM(fCode) |
| 268 |
DO NR=1,nRegs |
| 269 |
! Find the buffer for region I and field code with rank thisCodeRank |
| 270 |
NULLIFY(myBuf) |
| 271 |
CALL SRDIAG_GET_DATA_BUFFER( thisCodeRank, NR, diagVar, |
| 272 |
I iLoFld, jLoFld, kLoFld, |
| 273 |
I iHiFld, jHiFld, kHiFld, |
| 274 |
O myBuf, |
| 275 |
I myThid ) |
| 276 |
! Now do masked add of data to the subregion buffer pointed to by myBuf |
| 277 |
! PRINT *, 'HELLO 4 REGION', NR, TRIM(fCode) |
| 278 |
iB = 0 |
| 279 |
iLoMsk = LBOUND(diagVar%mList(NR)%mask,1) |
| 280 |
iLo = MAX(iLoFld, iLoMsk ) |
| 281 |
iHiMsk = UBOUND(diagVar%mList(NR)%mask,1) |
| 282 |
iHi = MIN(iHiFld, iHiMsk ) |
| 283 |
|
| 284 |
jLoMsk = LBOUND(diagVar%mList(NR)%mask,2) |
| 285 |
jLo = MAX(jLoFld, jLoMsk ) |
| 286 |
jHiMsk = UBOUND(diagVar%mList(NR)%mask,2) |
| 287 |
jHi = MIN(jHiFld, jHiMsk ) |
| 288 |
|
| 289 |
kLoMsk = LBOUND(diagVar%mList(NR)%mask,3) |
| 290 |
kLo = MAX(kLoFld, kLoMsk ) |
| 291 |
kHiMsk = UBOUND(diagVar%mList(NR)%mask,3) |
| 292 |
kHi = MIN(kHiFld, kHiMsk ) |
| 293 |
! PRINT *, 'HELLO 4 kLo, kHi', kLo, kHi |
| 294 |
! PRINT *, 'HELLO 4 jLo, jHi', jLo, jHi |
| 295 |
! PRINT *, 'HELLO 4 iLo, iHi', iLo, iHi |
| 296 |
DO K=kLo,kHi |
| 297 |
DO J=jLo,jHi |
| 298 |
DO I=iLo,iHi |
| 299 |
IF ( diagVar%mList(NR)%mask(I,J,K) .EQV. .TRUE. ) |
| 300 |
& THEN |
| 301 |
iFld=I-diagVar%cList(thisCodeRank)%iOffset |
| 302 |
jFld=J-diagVar%cList(thisCodeRank)%jOffset |
| 303 |
kFld=K-diagVar%cList(thisCodeRank)%kOffset |
| 304 |
iB =iB+1 |
| 305 |
! PRINT *, ' HELLO 7 ADDING TO BUFFER', myThid,iFld,jFld,kFld |
| 306 |
myBuf%r8Values(iB) = myBuf%r8Values(iB)+ |
| 307 |
& fld(iFld,jFld,kFld) |
| 308 |
& *alpha*diagVar%cList(thisCodeRank)%mFactor |
| 309 |
! PRINT *, ' HELLO 7 ADDED TO BUFFER', myThid,iFld,jFld,kFld |
| 310 |
ENDIF |
| 311 |
ENDDO |
| 312 |
ENDDO |
| 313 |
ENDDO |
| 314 |
ENDDO |
| 315 |
|
| 316 |
! PRINT *, 'HELLO 4 LEAVING FIELD ADD' |
| 317 |
|
| 318 |
RETURN |
| 319 |
END SUBROUTINE |
| 320 |
|
| 321 |
SUBROUTINE SRDIAG_GET_DATA_BUFFER( thisCodeRank, thisRegionRank, |
| 322 |
I diagVar, |
| 323 |
I iLoFld, |
| 324 |
I jLoFld, |
| 325 |
I kLoFld, |
| 326 |
I iHiFld, |
| 327 |
I jHiFld, |
| 328 |
I kHiFld, |
| 329 |
O theBuf, |
| 330 |
I myThid ) |
| 331 |
! Search through sub-region specification diagVar for data buffer |
| 332 |
! associated with the region with region rank "thisRegionRank" and the field code with |
| 333 |
! field code rank "thisCodeRank". |
| 334 |
! Return pointer to the buffer, creating the buffer if need be. |
| 335 |
! == Routine arguments == |
| 336 |
INTEGER :: thisCodeRank |
| 337 |
INTEGER :: thisRegionRank |
| 338 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 339 |
INTEGER :: iLoFld |
| 340 |
INTEGER :: jLoFld |
| 341 |
INTEGER :: kLoFld |
| 342 |
INTEGER :: iHiFld |
| 343 |
INTEGER :: jHiFld |
| 344 |
INTEGER :: kHiFld |
| 345 |
TYPE(SRDIAG_BUFFER), POINTER :: theBuf |
| 346 |
INTEGER :: myThid |
| 347 |
|
| 348 |
! == Local variables == |
| 349 |
INTEGER :: nRegs, nBufs, I, J, K, nCells |
| 350 |
INTEGER :: iLo, iHi, iLoMsk, iHiMsk |
| 351 |
INTEGER :: jLo, jHi, jLoMsk, jHiMsk |
| 352 |
INTEGER :: kLo, kHi, kLoMsk, kHiMsk |
| 353 |
TYPE(SRDIAG_BUFFER), POINTER :: dBufs(:) |
| 354 |
TYPE(SRDIAG_BUFFER), POINTER :: tempBList(:) |
| 355 |
|
| 356 |
! PRINT *, 'HELLO 4 GET_DATA_BUFFER', thisCodeRank, thisRegionRank |
| 357 |
! |
| 358 |
CALL SRDIAG_GET_DATA_BUFFER_NOCREATE( |
| 359 |
I thisCodeRank, thisRegionRank, diagVar, |
| 360 |
O theBuf, |
| 361 |
I myThid ) |
| 362 |
! |
| 363 |
! If we didn't find a buffer we need to create it |
| 364 |
IF ( .NOT. ASSOCIATED(theBuf) ) THEN |
| 365 |
! First need to figure out how big the buffer needs to be |
| 366 |
! We have two sets of indices |
| 367 |
! fld (iLoFld:iHiFld,jLoFld:jHiFld,kLoFld:kHiFld) and |
| 368 |
! mask(iLo:iLo+nX-1,jLo:jLo+nY-1,kLo:kLo+nR-1) |
| 369 |
! the number of cells we will have in buffer is the number of |
| 370 |
! mask values that are true in the fld index range. However, |
| 371 |
! we _must_not_ simpy reference mask with fld index ranges |
| 372 |
! because they may lie outside the valid index range for mask. |
| 373 |
nCells = 0 |
| 374 |
iLoMsk = LBOUND(diagVar%mList(thisRegionRank)%mask,1) |
| 375 |
iLo = MAX(iLoFld, iLoMsk ) |
| 376 |
iHiMsk = UBOUND(diagVar%mList(thisRegionRank)%mask,1) |
| 377 |
iHi = MIN(iHiFld, iHiMsk ) |
| 378 |
|
| 379 |
jLoMsk = LBOUND(diagVar%mList(thisRegionRank)%mask,2) |
| 380 |
jLo = MAX(jLoFld, jLoMsk ) |
| 381 |
jHiMsk = UBOUND(diagVar%mList(thisRegionRank)%mask,2) |
| 382 |
jHi = MIN(jHiFld, jHiMsk ) |
| 383 |
|
| 384 |
kLoMsk = LBOUND(diagVar%mList(thisRegionRank)%mask,3) |
| 385 |
kLo = MAX(kLoFld, kLoMsk ) |
| 386 |
kHiMsk = UBOUND(diagVar%mList(thisRegionRank)%mask,3) |
| 387 |
kHi = MIN(kHiFld, kHiMsk ) |
| 388 |
DO K=kLo,kHi |
| 389 |
DO J=jLo,jHi |
| 390 |
DO I=iLo,iHi |
| 391 |
IF ( diagVar%mList(thisRegionRank)%mask(I,J,K) .EQV. .TRUE. ) |
| 392 |
& THEN |
| 393 |
nCells = nCells+1 |
| 394 |
ENDIF |
| 395 |
ENDDO |
| 396 |
ENDDO |
| 397 |
ENDDO |
| 398 |
! PRINT *, 'HELLO 4 iLo, iHi = ', iLo, iHi |
| 399 |
! PRINT *, 'HELLO 4 jLo, jHi = ', jLo, jHi |
| 400 |
! PRINT *, 'HELLO 4 kLo, kHi = ', kLo, kHi |
| 401 |
! PRINT *, 'HELLO 4 nCells = ', nCells, thisRegionRank,thisCodeRank |
| 402 |
! Add a new entry at the end of the sub-region buffer list |
| 403 |
IF ( ASSOCIATED(diagVar%bList) ) THEN |
| 404 |
! List is not empty so we need to increase its size |
| 405 |
nBufs = UBOUND(diagVar%bList,1) |
| 406 |
ALLOCATE(tempBList(nBufs)) |
| 407 |
tempBList = diagVar%bList |
| 408 |
DEALLOCATE(diagVar%bList) |
| 409 |
ALLOCATE(diagVar%bList(nBufs+1)) |
| 410 |
diagVar%bList(1:nBufs) = tempBList |
| 411 |
ALLOCATE(theBuf) |
| 412 |
diagVar%bList(nBufs+1) = theBuf |
| 413 |
ELSE |
| 414 |
! List is empty so we create for first time |
| 415 |
ALLOCATE(diagVar%bList(1)) |
| 416 |
ALLOCATE(theBuf) |
| 417 |
diagVar%bList(1) = theBuf |
| 418 |
ENDIF |
| 419 |
|
| 420 |
! Now fill out the new buffer (which is at the end of the list) |
| 421 |
nBufs = UBOUND(diagVar%bList,1) |
| 422 |
! Add ranks and initial flags |
| 423 |
diagVar%bList(nBufs)%metaWritten = .FALSE. |
| 424 |
diagVar%bList(nBufs)%vType = SRDIAG_R8TYPE |
| 425 |
diagVar%bList(nBufs)%fCodeRank = thisCodeRank |
| 426 |
diagVar%bList(nBufs)%regionRank = thisRegionRank |
| 427 |
|
| 428 |
! Add data buffer to the entry at the end |
| 429 |
NULLIFY(diagVar%bList(nBufs)%r8Values) |
| 430 |
NULLIFY(diagVar%bList(nBufs)%r4Values) |
| 431 |
NULLIFY(diagVar%bList(nBufs)%iValues) |
| 432 |
IF ( nCells .GT. 0 ) THEN |
| 433 |
ALLOCATE(diagVar%bList(nBufs)%r8Values(nCells) ) |
| 434 |
! For a newly allocated buffer we set the initial value to zero |
| 435 |
diagVar%bList(nBufs)%r8Values = 0. |
| 436 |
ENDIF |
| 437 |
theBuf => diagVar%bList(nBufs) |
| 438 |
ENDIF |
| 439 |
|
| 440 |
RETURN |
| 441 |
END SUBROUTINE |
| 442 |
|
| 443 |
SUBROUTINE SRDIAG_GET_DATA_BUFFER_NOCREATE( thisCodeRank, |
| 444 |
I thisRegionRank, |
| 445 |
I diagVar, |
| 446 |
O theBuf, |
| 447 |
I myThid ) |
| 448 |
! Search through sub-region specification diagVar for data buffer |
| 449 |
! associated with the region with region rank "thisRegionRank" and the field code with |
| 450 |
! field code rank "thisCodeRank". |
| 451 |
! Return pointer to the buffer. |
| 452 |
! == Routine arguments == |
| 453 |
INTEGER :: thisCodeRank |
| 454 |
INTEGER :: thisRegionRank |
| 455 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 456 |
TYPE(SRDIAG_BUFFER), POINTER :: theBuf |
| 457 |
INTEGER :: myThid |
| 458 |
|
| 459 |
! == Local variables == |
| 460 |
INTEGER :: nRegs, nBufs, I, J |
| 461 |
TYPE(SRDIAG_BUFFER), POINTER :: dBufs(:) |
| 462 |
|
| 463 |
! |
| 464 |
NULLIFY(theBuf) |
| 465 |
nRegs = diagVar%nPointSets |
| 466 |
IF ( ASSOCIATED(diagVar%bList) ) THEN |
| 467 |
DO J=1,nRegs |
| 468 |
dBufs => diagVar%bList |
| 469 |
nBufs = UBOUND( dBufs,1 ) |
| 470 |
! Work through the buffers |
| 471 |
DO I=1,nBufs |
| 472 |
! Select buffers associated with this codes rank |
| 473 |
IF ( diagVar%bList(I)%fCodeRank .EQ. thisCodeRank .AND. |
| 474 |
& diagVar%bList(I)%regionRank .EQ. thisRegionRank ) THEN |
| 475 |
! PRINT *, 'FOUND BUFFER FOR rank, code', thisCodeRank, |
| 476 |
! & thisRegionRank |
| 477 |
theBuf => diagVar%bList(I) |
| 478 |
ENDIF |
| 479 |
ENDDO |
| 480 |
ENDDO |
| 481 |
ENDIF |
| 482 |
! |
| 483 |
RETURN |
| 484 |
END SUBROUTINE |
| 485 |
|
| 486 |
SUBROUTINE SRDIAG_GET_FIELD_CODE_RANK( |
| 487 |
I fCode, diagVar, |
| 488 |
O thisCodeRank, |
| 489 |
I myThid ) |
| 490 |
|
| 491 |
! == Routine arguments == |
| 492 |
CHARACTER*(*) :: fCode |
| 493 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 494 |
INTEGER :: thisCodeRank |
| 495 |
INTEGER :: myThid |
| 496 |
|
| 497 |
! == Local variables == |
| 498 |
INTEGER :: I |
| 499 |
|
| 500 |
thisCodeRank = 0 |
| 501 |
IF ( ASSOCIATED(diagVar%cList) ) THEN |
| 502 |
DO I=1,UBOUND(diagVar%cList,1) |
| 503 |
IF ( diagVar%cList(I)%fCode .EQ. fCode ) THEN |
| 504 |
thisCodeRank = I |
| 505 |
ENDIF |
| 506 |
ENDDO |
| 507 |
ENDIF |
| 508 |
|
| 509 |
RETURN |
| 510 |
END SUBROUTINE |
| 511 |
|
| 512 |
SUBROUTINE SRDIAG_INIT( myThid ) |
| 513 |
! |
| 514 |
! Initialize the SR_DIAGS package |
| 515 |
! Doesn't do anything! |
| 516 |
! |
| 517 |
! myThid :: Thread rank |
| 518 |
INTEGER myThid |
| 519 |
|
| 520 |
RETURN |
| 521 |
END SUBROUTINE |
| 522 |
|
| 523 |
SUBROUTINE SRDIAG_SCALE( alpha, fCode, diagVar, myThid ) |
| 524 |
! == Routine arguments == |
| 525 |
REAL*8 :: alpha |
| 526 |
CHARACTER*(*) :: fCode |
| 527 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 528 |
INTEGER :: myThid |
| 529 |
|
| 530 |
! == Local variables == |
| 531 |
INTEGER :: nRegs, nBufs |
| 532 |
INTEGER :: I, J, rC, thisCodeRank, NR |
| 533 |
INTEGER :: iB |
| 534 |
TYPE(SRDIAG_BUFFER), POINTER :: myBufs(:) |
| 535 |
TYPE(SRDIAG_BUFFER), POINTER :: myBuf |
| 536 |
INTEGER :: iLoFld, jLoFld, kLoFld |
| 537 |
INTEGER :: iHiFld, jHiFld, kHiFld |
| 538 |
INTEGER :: iLo, iHi, jLo, jHi, kLo, kHi |
| 539 |
|
| 540 |
! Determine the field code rank for the field code fCode within subregion diagVar. |
| 541 |
CALL SRDIAG_GET_FIELD_CODE_RANK( |
| 542 |
I fCode, diagVar, |
| 543 |
O thisCodeRank, |
| 544 |
I myThid ) |
| 545 |
IF ( thisCodeRank .EQ. 0 ) RETURN |
| 546 |
! PRINT *, ' HELLO 5 thisCodeRank = ', thisCodeRank, myThid |
| 547 |
|
| 548 |
! Look for existing buffers for this code for each region. |
| 549 |
nRegs = diagVar%nPointSets |
| 550 |
DO NR=1,nRegs |
| 551 |
! Find the buffer for region NR and field code with rank thisCodeRank |
| 552 |
CALL SRDIAG_GET_DATA_BUFFER_NOCREATE( thisCodeRank, NR, diagVar, |
| 553 |
O myBuf, |
| 554 |
I myThid ) |
| 555 |
! Now scale the buffer values |
| 556 |
IF ( ASSOCIATED(myBuf) ) THEN |
| 557 |
IF ( ASSOCIATED(myBuf%r8Values) ) THEN |
| 558 |
! PRINT *, ' HELLO 6 ASSOCIATED ', myThid |
| 559 |
myBuf%r8Values = myBuf%r8Values*alpha |
| 560 |
ELSE |
| 561 |
! PRINT *, ' HELLO 6 NOT ASSOCIATED ', myThid |
| 562 |
ENDIF |
| 563 |
ENDIF |
| 564 |
ENDDO |
| 565 |
|
| 566 |
RETURN |
| 567 |
END SUBROUTINE |
| 568 |
|
| 569 |
SUBROUTINE SRDIAG_STORE( diagVar, curTime, myThid ) |
| 570 |
TYPE(SRDIAG_SPEC), POINTER :: diagVar |
| 571 |
INTEGER :: myThid |
| 572 |
REAL*8 :: curTime |
| 573 |
|
| 574 |
INTEGER :: iUnit |
| 575 |
INTEGER :: NB |
| 576 |
INTEGER :: I, rr, fr, J |
| 577 |
INTEGER*8 :: iLo8, iHi8, jLo8, jHi8, |
| 578 |
& kLo8, kHi8 |
| 579 |
INTEGER*8 :: rr8 |
| 580 |
INTEGER*8 :: npt8 |
| 581 |
CHARACTER*512 :: fC512 |
| 582 |
INTEGER*4 :: dFlag4 |
| 583 |
|
| 584 |
CHARACTER*8 :: vString |
| 585 |
INTEGER :: dFPointsStruct |
| 586 |
INTEGER :: dFPointsUnStruct |
| 587 |
INTEGER :: dFData |
| 588 |
PARAMETER ( vString = 'v001 ', |
| 589 |
& dFPointsStruct = 0, |
| 590 |
& dFPointsUnStruct = 1, |
| 591 |
& dFData = 2 ) |
| 592 |
|
| 593 |
CALL MDSFINDUNIT( iUnit, myThid ) |
| 594 |
OPEN(unit=iUnit,file=TRIM(diagVar%outName), |
| 595 |
& FORM='unformatted',STATUS='OLD', |
| 596 |
& POSITION='APPEND') |
| 597 |
IF ( diagVar%vWritten .EQV. .FALSE. ) THEN |
| 598 |
WRITE(iunit) vString |
| 599 |
diagVar%vWritten = .TRUE. |
| 600 |
ENDIF |
| 601 |
IF ( .NOT. ASSOCIATED(diagVar%bList) ) THEN |
| 602 |
CLOSE( iUnit ) |
| 603 |
RETURN |
| 604 |
ENDIF |
| 605 |
! Need to store each code for each region |
| 606 |
! Use following format for data |
| 607 |
! "dflag4bytes" "fieldcode512bytes" "regionRank8bytes" "time8bytes" "npoints8bytes" (data8bytes) x npoints |
| 608 |
! On first write need to write index ranges for the code and region |
| 609 |
! (for scatter point set) |
| 610 |
! "dflag4bytes" "fieldcode512bytes" "regionRank8bytes" "avPeriodr8" "npoints8bytes" (ival8bytes jval8bytes kval8bytes) x npoints |
| 611 |
! -or- (for structured point set) |
| 612 |
! "dflag4bytes" "fieldcode512bytes" "regionRank8bytes" "avPeriod8" ilo8bytes ihi8bytes jlo8bytes jhi8bytes klo8bytes khi8bytes |
| 613 |
NB = UBOUND(diagVar%bList,1) |
| 614 |
DO I = 1, NB |
| 615 |
IF ( ASSOCIATED(diagVar%bList(I)%r8Values) ) THEN |
| 616 |
! This buffer has some data |
| 617 |
rr = diagVar%bList(I)%regionRank |
| 618 |
fr = diagVar%bList(I)%fCodeRank |
| 619 |
rr8 = rr |
| 620 |
npt8 = UBOUND(diagVar%bList(I)%r8Values,1) |
| 621 |
fC512 = TRIM(diagVar%cList(fr)%fCode) |
| 622 |
IF ( diagVar%bList(I)%metaWritten .EQV. .FALSE. ) THEN |
| 623 |
! Write meta data if it hasn't already been written |
| 624 |
iLo8 = MAX(LBOUND(diagVar%mList(rr)%mask,1), |
| 625 |
& diagVar%mList(rr)%iLo |
| 626 |
& ) |
| 627 |
iHi8 = MIN(UBOUND(diagVar%mList(rr)%mask,1), |
| 628 |
& diagVar%mList(rr)%iLo+ |
| 629 |
& diagVar%mList(rr)%nX-1 |
| 630 |
& ) |
| 631 |
jLo8 = MAX(LBOUND(diagVar%mList(rr)%mask,2), |
| 632 |
& diagVar%mList(rr)%jLo |
| 633 |
& ) |
| 634 |
jHi8 = MIN(UBOUND(diagVar%mList(rr)%mask,2), |
| 635 |
& diagVar%mList(rr)%jLo+ |
| 636 |
& diagVar%mList(rr)%nY-1 |
| 637 |
& ) |
| 638 |
kLo8 = MAX(LBOUND(diagVar%mList(rr)%mask,3), |
| 639 |
& diagVar%mList(rr)%kLo |
| 640 |
& ) |
| 641 |
kHi8 = MIN(UBOUND(diagVar%mList(rr)%mask,3), |
| 642 |
& diagVar%mList(rr)%kLo+ |
| 643 |
& diagVar%mList(rr)%nR-1 |
| 644 |
& ) |
| 645 |
WRITE(iUnit) dFPointsStruct, fC512, rr8, diagVar%aPeriod, |
| 646 |
& iLo8, iHi8, jLo8, jHi8, kLo8, kHi8 |
| 647 |
diagVar%bList(I)%metaWritten = .TRUE. |
| 648 |
ENDIF |
| 649 |
! Now write the data |
| 650 |
diagVar%bList(I)%r8Values= |
| 651 |
& diagVar%bList(I)%r8Values/diagVar%aPeriod |
| 652 |
WRITE(iUnit) dfData, fc512, rr8, curTime, npt8, |
| 653 |
& (diagVar%bList(I)%r8Values(J),J=1,npt8 ) |
| 654 |
diagVar%bList(I)%r8Values=0. |
| 655 |
! WRITE(iunit) 1.0 |
| 656 |
ENDIF |
| 657 |
ENDDO |
| 658 |
CLOSE(iUnit) |
| 659 |
|
| 660 |
RETURN |
| 661 |
END SUBROUTINE |
| 662 |
END MODULE |
Parent Directory
| 
Revision Log
| 
Revision Graph