- Timestamp:
- 2018-11-07T18:25:49+01:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2018/dev_r9866_HPC_03_globcom/src/SAO/obs_fbm.F90
- Property svn:special deleted
- Property svn:keywords set to Id
r9598 r10288 1 link ../OCE/OBS/obs_fbm.F90 1 MODULE obs_fbm 2 !!====================================================================== 3 !! *** MODULE obs_fbm *** 4 !! Observation operators : I/O + tools for feedback files 5 !!====================================================================== 6 !! History : 7 !! ! 08-11 (K. Mogensen) Initial version 8 !!---------------------------------------------------------------------- 9 10 !!---------------------------------------------------------------------- 11 !! init_obfbdata : Initialize sizes in obfbdata structure 12 !! alloc_obfbdata : Allocate data in an obfbdata structure 13 !! dealloc_obfbdata : Dellocate data in an obfbdata structure 14 !! copy_obfbdata : Copy an obfbdata structure 15 !! subsamp_obfbdata : Sumsample an obfbdata structure 16 !! merge_obfbdata : Merge multiple obfbdata structures into an one. 17 !! write_obfbdata : Write an obfbdata structure into a netCDF file. 18 !! read_obfbdata : Read an obfbdata structure from a netCDF file. 19 !!---------------------------------------------------------------------- 20 USE netcdf 21 USE obs_utils ! Various utilities for observation operators 22 23 IMPLICIT NONE 24 PUBLIC 25 26 ! Type kinds for feedback data. 27 28 INTEGER, PARAMETER :: fbsp = SELECTED_REAL_KIND( 6, 37) !: single precision 29 INTEGER, PARAMETER :: fbdp = SELECTED_REAL_KIND(12,307) !: double precision 30 31 ! Parameters for string lengths. 32 33 INTEGER, PARAMETER :: ilenwmo = 8 !: Length of station identifier 34 INTEGER, PARAMETER :: ilentyp = 4 !: Length of type 35 INTEGER, PARAMETER :: ilenname = 8 !: Length of variable names 36 INTEGER, PARAMETER :: ilengrid = 1 !: Grid (e.g. 'T') length 37 INTEGER, PARAMETER :: ilenjuld = 14 !: Lenght of reference julian date 38 INTEGER, PARAMETER :: idefnqcf = 2 !: Default number of words in QC 39 ! flags 40 INTEGER, PARAMETER :: ilenlong = 128 !: Length of long name 41 INTEGER, PARAMETER :: ilenunit = 32 !: Length of units 42 43 ! Missinge data indicators 44 45 INTEGER, PARAMETER :: fbimdi = -99999 !: Integers 46 REAL(fbsp), PARAMETER :: fbrmdi = 99999 !: Reals 47 48 ! Main data structure for observation feedback data. 49 50 TYPE obfbdata 51 LOGICAL :: lalloc !: Allocation status for data 52 LOGICAL :: lgrid !: Include grid search info 53 INTEGER :: nvar !: Number of variables 54 INTEGER :: nobs !: Number of observations 55 INTEGER :: nlev !: Number of levels 56 INTEGER :: nadd !: Number of additional entries 57 INTEGER :: next !: Number of extra variables 58 INTEGER :: nqcf !: Number of words per qc flag 59 CHARACTER(LEN=ilenwmo), DIMENSION(:), POINTER :: & 60 & cdwmo !: Identifier 61 CHARACTER(LEN=ilentyp), DIMENSION(:), POINTER :: & 62 & cdtyp !: Instrument type 63 CHARACTER(LEN=ilenjuld) :: & 64 & cdjuldref !: Julian date reference 65 INTEGER, DIMENSION(:), POINTER :: & 66 & kindex !: Index of observations in the original file 67 INTEGER, DIMENSION(:), POINTER :: & 68 & ioqc, & !: Observation QC 69 & ipqc, & !: Position QC 70 & itqc !: Time QC 71 INTEGER, DIMENSION(:,:), POINTER :: & 72 & ioqcf, & !: Observation QC flags 73 & ipqcf, & !: Position QC flags 74 & itqcf !: Time QC flags 75 INTEGER, DIMENSION(:,:), POINTER :: & 76 & idqc !: Depth QC 77 INTEGER, DIMENSION(:,:,:), POINTER :: & 78 & idqcf !: Depth QC flags 79 REAL(KIND=fbdp), DIMENSION(:), POINTER :: & 80 & plam, & !: Longitude 81 & pphi, & !: Latitude 82 & ptim !: Time 83 REAL(KIND=fbsp), DIMENSION(:,:), POINTER :: & 84 & pdep !: Depth 85 CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & 86 & cname !: Name of variable 87 REAL(fbsp), DIMENSION(:,:,:), POINTER :: & 88 & pob !: Observation 89 CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & 90 & coblong !: Observation long name (for output) 91 CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & 92 & cobunit !: Observation units (for output) 93 INTEGER, DIMENSION(:,:), POINTER :: & 94 & ivqc !: Variable QC 95 INTEGER, DIMENSION(:,:,:), POINTER :: & 96 & ivqcf !: Variable QC flags 97 INTEGER, DIMENSION(:,:,:), POINTER :: & 98 & ivlqc !: Variable level QC 99 INTEGER, DIMENSION(:,:,:,:), POINTER :: & 100 & ivlqcf !: Variable level QC flags 101 INTEGER, DIMENSION(:,:), POINTER :: & 102 & iproc, & !: Processor of obs (no I/O for this variable). 103 & iobsi, & !: Global i index 104 & iobsj !: Global j index 105 INTEGER, DIMENSION(:,:,:), POINTER :: & 106 & iobsk !: k index 107 CHARACTER(LEN=ilengrid), DIMENSION(:), POINTER :: & 108 & cgrid !: Grid for this variable 109 CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & 110 & caddname !: Additional entries names 111 CHARACTER(LEN=ilenlong), DIMENSION(:,:), POINTER :: & 112 & caddlong !: Additional entries long name (for output) 113 CHARACTER(LEN=ilenunit), DIMENSION(:,:), POINTER :: & 114 & caddunit !: Additional entries units (for output) 115 REAL(fbsp), DIMENSION(:,:,:,:) , POINTER :: & 116 & padd !: Additional entries 117 CHARACTER(LEN=ilenname), DIMENSION(:), POINTER :: & 118 & cextname !: Extra variables names 119 CHARACTER(LEN=ilenlong), DIMENSION(:), POINTER :: & 120 & cextlong !: Extra variables long name (for output) 121 CHARACTER(LEN=ilenunit), DIMENSION(:), POINTER :: & 122 & cextunit !: Extra variables units (for output) 123 REAL(fbsp), DIMENSION(:,:,:) , POINTER :: & 124 & pext !: Extra variables 125 END TYPE obfbdata 126 127 PRIVATE putvaratt_obfbdata 128 129 !!---------------------------------------------------------------------- 130 !! NEMO/OCE 4.0 , NEMO Consortium (2018) 131 !! $Id$ 132 !! Software governed by the CeCILL license (see ./LICENSE) 133 !!---------------------------------------------------------------------- 134 135 CONTAINS 136 137 SUBROUTINE init_obfbdata( fbdata ) 138 !!---------------------------------------------------------------------- 139 !! *** ROUTINE init_obfbdata *** 140 !! 141 !! ** Purpose : Initialize sizes in obfbdata structure 142 !! 143 !! ** Method : 144 !! 145 !! ** Action : 146 !! 147 !!---------------------------------------------------------------------- 148 !! * Arguments 149 TYPE(obfbdata) :: fbdata ! obsfbdata structure 150 151 fbdata%nvar = 0 152 fbdata%nobs = 0 153 fbdata%nlev = 0 154 fbdata%nadd = 0 155 fbdata%next = 0 156 fbdata%nqcf = idefnqcf 157 fbdata%lalloc = .FALSE. 158 fbdata%lgrid = .FALSE. 159 160 END SUBROUTINE init_obfbdata 161 162 SUBROUTINE alloc_obfbdata( fbdata, kvar, kobs, klev, kadd, kext, lgrid, & 163 & kqcf) 164 !!---------------------------------------------------------------------- 165 !! *** ROUTINE alloc_obfbdata *** 166 !! 167 !! ** Purpose : Allocate data in an obfbdata structure 168 !! 169 !! ** Method : 170 !! 171 !! ** Action : 172 !! 173 !!---------------------------------------------------------------------- 174 !! * Arguments 175 TYPE(obfbdata) :: fbdata ! obsfbdata structure to be allocated 176 INTEGER, INTENT(IN) :: kvar ! Number of variables 177 INTEGER, INTENT(IN) :: kobs ! Number of observations 178 INTEGER, INTENT(IN) :: klev ! Number of levels 179 INTEGER, INTENT(IN) :: kadd ! Number of additional entries 180 INTEGER, INTENT(IN) :: kext ! Number of extra variables 181 LOGICAL, INTENT(IN) :: lgrid ! Include grid search information 182 INTEGER, OPTIONAL :: kqcf ! Number of words for QC flags 183 !! * Local variables 184 INTEGER :: ji 185 INTEGER :: jv 186 187 ! Check allocation status and deallocate previous allocated structures 188 189 IF ( fbdata%lalloc ) THEN 190 CALL dealloc_obfbdata( fbdata ) 191 ENDIF 192 193 ! Set dimensions 194 195 fbdata%lalloc = .TRUE. 196 fbdata%nvar = kvar 197 fbdata%nobs = kobs 198 fbdata%nlev = MAX( klev, 1 ) 199 fbdata%nadd = kadd 200 fbdata%next = kext 201 IF ( PRESENT(kqcf) ) THEN 202 fbdata%nqcf = kqcf 203 ELSE 204 fbdata%nqcf = idefnqcf 205 ENDIF 206 207 ! Set data not depending on number of observations 208 209 fbdata%cdjuldref = REPEAT( 'X', ilenjuld ) 210 211 ! Allocate and initialize standard data 212 213 ALLOCATE( & 214 & fbdata%cname(fbdata%nvar), & 215 & fbdata%coblong(fbdata%nvar), & 216 & fbdata%cobunit(fbdata%nvar) & 217 & ) 218 DO ji = 1, fbdata%nvar 219 WRITE(fbdata%cname(ji),'(A,I2.2)')'V_',ji 220 fbdata%coblong(ji) = REPEAT( ' ', ilenlong ) 221 fbdata%cobunit(ji) = REPEAT( ' ', ilenunit ) 222 END DO 223 224 ! Optionally also store grid search information 225 226 IF ( lgrid ) THEN 227 ALLOCATE ( & 228 & fbdata%cgrid(fbdata%nvar) & 229 & ) 230 fbdata%cgrid(:) = REPEAT( 'X', ilengrid ) 231 fbdata%lgrid = .TRUE. 232 ENDIF 233 234 ! Allocate and initialize additional entries if present 235 236 IF ( fbdata%nadd > 0 ) THEN 237 ALLOCATE( & 238 & fbdata%caddname(fbdata%nadd), & 239 & fbdata%caddlong(fbdata%nadd, fbdata%nvar), & 240 & fbdata%caddunit(fbdata%nadd, fbdata%nvar) & 241 & ) 242 DO ji = 1, fbdata%nadd 243 WRITE(fbdata%caddname(ji),'(A,I2.2)')'A',ji 244 END DO 245 DO jv = 1, fbdata%nvar 246 DO ji = 1, fbdata%nadd 247 fbdata%caddlong(ji,jv) = REPEAT( ' ', ilenlong ) 248 fbdata%caddunit(ji,jv) = REPEAT( ' ', ilenunit ) 249 END DO 250 END DO 251 ENDIF 252 253 ! Allocate and initialize additional variables if present 254 255 IF ( fbdata%next > 0 ) THEN 256 ALLOCATE( & 257 & fbdata%cextname(fbdata%next), & 258 & fbdata%cextlong(fbdata%next), & 259 & fbdata%cextunit(fbdata%next) & 260 & ) 261 DO ji = 1, fbdata%next 262 WRITE(fbdata%cextname(ji),'(A,I2.2)')'E_',ji 263 fbdata%cextlong(ji) = REPEAT( ' ', ilenlong ) 264 fbdata%cextunit(ji) = REPEAT( ' ', ilenunit ) 265 END DO 266 ENDIF 267 268 ! Data depending on number of observations is only allocated if nobs>0 269 270 IF ( fbdata%nobs > 0 ) THEN 271 272 ALLOCATE( & 273 & fbdata%cdwmo(fbdata%nobs), & 274 & fbdata%cdtyp(fbdata%nobs), & 275 & fbdata%ioqc(fbdata%nobs), & 276 & fbdata%ioqcf(fbdata%nqcf,fbdata%nobs), & 277 & fbdata%ipqc(fbdata%nobs), & 278 & fbdata%ipqcf(fbdata%nqcf,fbdata%nobs), & 279 & fbdata%itqc(fbdata%nobs), & 280 & fbdata%itqcf(fbdata%nqcf,fbdata%nobs), & 281 & fbdata%idqc(fbdata%nlev,fbdata%nobs), & 282 & fbdata%idqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs), & 283 & fbdata%plam(fbdata%nobs), & 284 & fbdata%pphi(fbdata%nobs), & 285 & fbdata%pdep(fbdata%nlev,fbdata%nobs), & 286 & fbdata%ptim(fbdata%nobs), & 287 & fbdata%kindex(fbdata%nobs), & 288 & fbdata%ivqc(fbdata%nobs,fbdata%nvar), & 289 & fbdata%ivqcf(fbdata%nqcf,fbdata%nobs,fbdata%nvar), & 290 & fbdata%ivlqc(fbdata%nlev,fbdata%nobs,fbdata%nvar), & 291 & fbdata%ivlqcf(fbdata%nqcf,fbdata%nlev,fbdata%nobs,fbdata%nvar), & 292 & fbdata%pob(fbdata%nlev,fbdata%nobs,fbdata%nvar) & 293 & ) 294 fbdata%kindex(:) = fbimdi 295 fbdata%cdwmo(:) = REPEAT( 'X', ilenwmo ) 296 fbdata%cdtyp(:) = REPEAT( 'X', ilentyp ) 297 fbdata%ioqc(:) = fbimdi 298 fbdata%ioqcf(:,:) = fbimdi 299 fbdata%ipqc(:) = fbimdi 300 fbdata%ipqcf(:,:) = fbimdi 301 fbdata%itqc(:) = fbimdi 302 fbdata%itqcf(:,:) = fbimdi 303 fbdata%idqc(:,:) = fbimdi 304 fbdata%idqcf(:,:,:) = fbimdi 305 fbdata%plam(:) = fbrmdi 306 fbdata%pphi(:) = fbrmdi 307 fbdata%pdep(:,:) = fbrmdi 308 fbdata%ptim(:) = fbrmdi 309 fbdata%ivqc(:,:) = fbimdi 310 fbdata%ivqcf(:,:,:) = fbimdi 311 fbdata%ivlqc(:,:,:) = fbimdi 312 fbdata%ivlqcf(:,:,:,:) = fbimdi 313 fbdata%pob(:,:,:) = fbrmdi 314 315 ! Optionally also store grid search information 316 317 IF ( lgrid ) THEN 318 ALLOCATE ( & 319 & fbdata%iproc(fbdata%nobs,fbdata%nvar), & 320 & fbdata%iobsi(fbdata%nobs,fbdata%nvar), & 321 & fbdata%iobsj(fbdata%nobs,fbdata%nvar), & 322 & fbdata%iobsk(fbdata%nlev,fbdata%nobs,fbdata%nvar) & 323 & ) 324 fbdata%iproc(:,:) = fbimdi 325 fbdata%iobsi(:,:) = fbimdi 326 fbdata%iobsj(:,:) = fbimdi 327 fbdata%iobsk(:,:,:) = fbimdi 328 fbdata%lgrid = .TRUE. 329 ENDIF 330 331 ! Allocate and initialize additional entries if present 332 333 IF ( fbdata%nadd > 0 ) THEN 334 ALLOCATE( & 335 & fbdata%padd(fbdata%nlev,fbdata%nobs,fbdata%nadd,fbdata%nvar) & 336 & ) 337 fbdata%padd(:,:,:,:) = fbrmdi 338 ENDIF 339 340 ! Allocate and initialize additional variables if present 341 342 IF ( fbdata%next > 0 ) THEN 343 ALLOCATE( & 344 & fbdata%pext(fbdata%nlev,fbdata%nobs,fbdata%next) & 345 & ) 346 fbdata%pext(:,:,:) = fbrmdi 347 ENDIF 348 349 ENDIF 350 351 END SUBROUTINE alloc_obfbdata 352 353 SUBROUTINE dealloc_obfbdata( fbdata ) 354 !!---------------------------------------------------------------------- 355 !! *** ROUTINE dealloc_obfbdata *** 356 !! 357 !! ** Purpose : Deallocate data in an obfbdata strucure 358 !! 359 !! ** Method : 360 !! 361 !! ** Action : 362 !! 363 !!---------------------------------------------------------------------- 364 !! * Arguments 365 TYPE(obfbdata) :: fbdata ! obsfbdata structure 366 367 ! Deallocate data 368 369 DEALLOCATE( & 370 & fbdata%cname, & 371 & fbdata%coblong,& 372 & fbdata%cobunit & 373 & ) 374 375 ! Deallocate optional grid search information 376 377 IF ( fbdata%lgrid ) THEN 378 DEALLOCATE ( & 379 & fbdata%cgrid & 380 & ) 381 ENDIF 382 383 ! Deallocate additional entries 384 385 IF ( fbdata%nadd > 0 ) THEN 386 DEALLOCATE( & 387 & fbdata%caddname, & 388 & fbdata%caddlong, & 389 & fbdata%caddunit & 390 & ) 391 ENDIF 392 393 ! Deallocate extra variables 394 395 IF ( fbdata%next > 0 ) THEN 396 DEALLOCATE( & 397 & fbdata%cextname, & 398 & fbdata%cextlong, & 399 & fbdata%cextunit & 400 & ) 401 ENDIF 402 403 ! Deallocate arrays depending on number of obs (if nobs>0 only). 404 405 IF ( fbdata%nobs > 0 ) THEN 406 407 DEALLOCATE( & 408 & fbdata%cdwmo, & 409 & fbdata%cdtyp, & 410 & fbdata%ioqc, & 411 & fbdata%ioqcf, & 412 & fbdata%ipqc, & 413 & fbdata%ipqcf, & 414 & fbdata%itqc, & 415 & fbdata%itqcf, & 416 & fbdata%idqc, & 417 & fbdata%idqcf, & 418 & fbdata%plam, & 419 & fbdata%pphi, & 420 & fbdata%pdep, & 421 & fbdata%ptim, & 422 & fbdata%kindex, & 423 & fbdata%ivqc, & 424 & fbdata%ivqcf, & 425 & fbdata%ivlqc, & 426 & fbdata%ivlqcf, & 427 & fbdata%pob & 428 & ) 429 430 431 ! Deallocate optional grid search information 432 433 IF ( fbdata%lgrid ) THEN 434 DEALLOCATE ( & 435 & fbdata%iproc, & 436 & fbdata%iobsi, & 437 & fbdata%iobsj, & 438 & fbdata%iobsk & 439 & ) 440 ENDIF 441 442 ! Deallocate additional entries 443 444 IF ( fbdata%nadd > 0 ) THEN 445 DEALLOCATE( & 446 & fbdata%padd & 447 & ) 448 ENDIF 449 450 ! Deallocate extra variables 451 452 IF ( fbdata%next > 0 ) THEN 453 DEALLOCATE( & 454 & fbdata%pext & 455 & ) 456 ENDIF 457 458 ENDIF 459 460 ! Reset arrays sizes 461 462 fbdata%lalloc = .FALSE. 463 fbdata%lgrid = .FALSE. 464 fbdata%nvar = 0 465 fbdata%nobs = 0 466 fbdata%nlev = 0 467 fbdata%nadd = 0 468 fbdata%next = 0 469 470 END SUBROUTINE dealloc_obfbdata 471 472 SUBROUTINE copy_obfbdata( fbdata1, fbdata2, kadd, kext, lgrid, kqcf ) 473 !!---------------------------------------------------------------------- 474 !! *** ROUTINE copy_obfbdata *** 475 !! 476 !! ** Purpose : Copy an obfbdata structure 477 !! 478 !! ** Method : Copy all data from fbdata1 to fbdata2 479 !! If fbdata2 is allocated it needs to be compliant 480 !! with fbdata1. 481 !! Additional entries can be added by setting nadd 482 !! Additional extra fields can be added by setting next 483 !! Grid information can be included with lgrid=.true. 484 !! 485 !! ** Action : 486 !! 487 !!---------------------------------------------------------------------- 488 !! * Arguments 489 TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure 490 TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure 491 INTEGER, INTENT(IN), OPTIONAL :: kadd ! Number of additional entries 492 INTEGER, INTENT(IN), OPTIONAL :: kext ! Number of extra variables 493 INTEGER, INTENT(IN), OPTIONAL :: kqcf ! Number of words per qc flags 494 LOGICAL, OPTIONAL :: lgrid ! Grid info on output file 495 496 !! * Local variables 497 INTEGER :: nadd 498 INTEGER :: next 499 INTEGER :: nqcf 500 LOGICAL :: llgrid 501 INTEGER :: jv 502 INTEGER :: je 503 INTEGER :: ji 504 INTEGER :: jk 505 INTEGER :: jq 506 507 ! Check allocation status of fbdata1 508 509 IF ( .NOT. fbdata1%lalloc ) THEN 510 CALL fatal_error( 'copy_obfbdata: input data not allocated', & 511 & __LINE__ ) 512 ENDIF 513 514 ! If nadd,next not specified use the ones from fbdata1 515 ! Otherwise check that they have large than the original ones 516 517 IF ( PRESENT(kadd) ) THEN 518 nadd = kadd 519 IF ( nadd < fbdata1%nadd ) THEN 520 CALL warning ( 'copy_obfbdata: ' // & 521 & 'nadd smaller than input nadd', __LINE__ ) 522 ENDIF 523 ELSE 524 nadd = fbdata1%nadd 525 ENDIF 526 IF ( PRESENT(kext) ) THEN 527 next = kext 528 IF ( next < fbdata1%next ) THEN 529 CALL fatal_error( 'copy_obfbdata: ' // & 530 & 'next smaller than input next', __LINE__ ) 531 ENDIF 532 ELSE 533 next = fbdata1%next 534 ENDIF 535 IF ( PRESENT(lgrid) ) THEN 536 llgrid = lgrid 537 IF ( fbdata1%lgrid .AND. (.NOT. llgrid) ) THEN 538 CALL fatal_error( 'copy_obfbdata: ' // & 539 & 'switching off grid info not possible', & 540 & __LINE__ ) 541 ENDIF 542 ELSE 543 llgrid = fbdata1%lgrid 544 ENDIF 545 IF ( PRESENT(kqcf) ) THEN 546 nqcf = kqcf 547 IF ( nqcf < fbdata1%nqcf ) THEN 548 CALL fatal_error( 'copy_obfbdata: ' // & 549 & 'nqcf smaller than input nqcf', __LINE__ ) 550 ENDIF 551 ELSE 552 nqcf = fbdata1%nqcf 553 ENDIF 554 555 ! Check allocation status of fbdata2 and 556 ! a) check that it conforms in size if already allocated 557 ! b) allocate it if not already allocated 558 559 IF ( fbdata2%lalloc ) THEN 560 IF ( fbdata1%nvar > fbdata2%nvar ) THEN 561 CALL fatal_error( 'copy_obfbdata: ' // & 562 & 'output kvar smaller than input kvar', __LINE__ ) 563 ENDIF 564 IF ( fbdata1%nobs > fbdata2%nobs ) THEN 565 CALL fatal_error( 'copy_obfbdata: ' // & 566 & 'output kobs smaller than input kobs', __LINE__ ) 567 ENDIF 568 IF ( fbdata1%nlev > fbdata2%nlev ) THEN 569 CALL fatal_error( 'copy_obfbdata: ' // & 570 & 'output klev smaller than input klev', __LINE__ ) 571 ENDIF 572 IF ( fbdata1%nadd > fbdata2%nadd ) THEN 573 CALL warning ( 'copy_obfbdata: ' // & 574 & 'output nadd smaller than input nadd', __LINE__ ) 575 ENDIF 576 IF ( fbdata1%next > fbdata2%next ) THEN 577 CALL fatal_error( 'copy_obfbdata: ' // & 578 & 'output next smaller than input next', __LINE__ ) 579 ENDIF 580 IF ( fbdata1%lgrid .NEQV. fbdata2%lgrid ) THEN 581 CALL fatal_error( 'copy_obfbdata: ' // & 582 & 'lgrid inconsistent', __LINE__ ) 583 ENDIF 584 IF ( fbdata1%next > fbdata2%next ) THEN 585 CALL fatal_error( 'copy_obfbdata: ' // & 586 & 'output next smaller than input next', __LINE__ ) 587 ENDIF 588 IF ( fbdata1%nqcf > fbdata2%nqcf ) THEN 589 CALL fatal_error( 'copy_obfbdata: ' // & 590 & 'output smaller than input kext', __LINE__ ) 591 ENDIF 592 ELSE 593 CALL alloc_obfbdata( fbdata2, fbdata1%nvar, fbdata1%nobs, & 594 & fbdata1%nlev, nadd, next, llgrid, kqcf = nqcf ) 595 ENDIF 596 597 ! Copy the header data 598 599 fbdata2%cdjuldref = fbdata1%cdjuldref 600 601 DO ji = 1, fbdata1%nobs 602 fbdata2%cdwmo(ji) = fbdata1%cdwmo(ji) 603 fbdata2%cdtyp(ji) = fbdata1%cdtyp(ji) 604 fbdata2%ioqc(ji) = fbdata1%ioqc(ji) 605 fbdata2%ipqc(ji) = fbdata1%ipqc(ji) 606 fbdata2%itqc(ji) = fbdata1%itqc(ji) 607 fbdata2%plam(ji) = fbdata1%plam(ji) 608 fbdata2%pphi(ji) = fbdata1%pphi(ji) 609 fbdata2%ptim(ji) = fbdata1%ptim(ji) 610 fbdata2%kindex(ji) = fbdata1%kindex(ji) 611 DO jq = 1, fbdata1%nqcf 612 fbdata2%ioqcf(jq,ji) = fbdata1%ioqcf(jq,ji) 613 fbdata2%ipqcf(jq,ji) = fbdata1%ipqcf(jq,ji) 614 fbdata2%itqcf(jq,ji) = fbdata1%itqcf(jq,ji) 615 END DO 616 DO jk = 1, fbdata1%nlev 617 fbdata2%idqc(jk,ji) = fbdata1%idqc(jk,ji) 618 fbdata2%pdep(jk,ji) = fbdata1%pdep(jk,ji) 619 DO jq = 1, fbdata1%nqcf 620 fbdata2%idqcf(jq,jk,ji) = fbdata1%idqcf(jq,jk,ji) 621 END DO 622 END DO 623 END DO 624 625 ! Copy the variable data 626 627 DO jv = 1, fbdata1%nvar 628 fbdata2%cname(jv) = fbdata1%cname(jv) 629 fbdata2%coblong(jv) = fbdata1%coblong(jv) 630 fbdata2%cobunit(jv) = fbdata1%cobunit(jv) 631 DO ji = 1, fbdata1%nobs 632 fbdata2%ivqc(ji,jv) = fbdata1%ivqc(ji,jv) 633 DO jq = 1, fbdata1%nqcf 634 fbdata2%ivqcf(jq,ji,jv) = fbdata1%ivqcf(jq,ji,jv) 635 END DO 636 DO jk = 1, fbdata1%nlev 637 fbdata2%ivlqc(jk,ji,jv) = fbdata1%ivlqc(jk,ji,jv) 638 fbdata2%pob(jk,ji,jv) = fbdata1%pob(jk,ji,jv) 639 DO jq = 1, fbdata1%nqcf 640 fbdata2%ivlqcf(jq,jk,ji,jv) = fbdata1%ivlqcf(jq,jk,ji,jv) 641 END DO 642 END DO 643 END DO 644 END DO 645 646 ! Copy grid information 647 648 IF ( fbdata1%lgrid ) THEN 649 DO jv = 1, fbdata1%nvar 650 fbdata2%cgrid(jv) = fbdata1%cgrid(jv) 651 DO ji = 1, fbdata1%nobs 652 fbdata2%iproc(ji,jv) = fbdata1%iproc(ji,jv) 653 fbdata2%iobsi(ji,jv) = fbdata1%iobsi(ji,jv) 654 fbdata2%iobsj(ji,jv) = fbdata1%iobsj(ji,jv) 655 DO jk = 1, fbdata1%nlev 656 fbdata2%iobsk(jk,ji,jv) = fbdata1%iobsk(jk,ji,jv) 657 END DO 658 END DO 659 END DO 660 ENDIF 661 662 ! Copy additional information 663 664 DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd ) 665 fbdata2%caddname(je) = fbdata1%caddname(je) 666 END DO 667 DO jv = 1, fbdata1%nvar 668 DO je = 1, MIN( fbdata1%nadd, fbdata2%nadd ) 669 fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv) 670 fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv) 671 DO ji = 1, fbdata1%nobs 672 DO jk = 1, fbdata1%nlev 673 fbdata2%padd(jk,ji,je,jv) = fbdata1%padd(jk,ji,je,jv) 674 END DO 675 END DO 676 END DO 677 END DO 678 679 ! Copy extra information 680 681 DO je = 1, fbdata1%next 682 fbdata2%cextname(je) = fbdata1%cextname(je) 683 fbdata2%cextlong(je) = fbdata1%cextlong(je) 684 fbdata2%cextunit(je) = fbdata1%cextunit(je) 685 END DO 686 DO je = 1, fbdata1%next 687 DO ji = 1, fbdata1%nobs 688 DO jk = 1, fbdata1%nlev 689 fbdata2%pext(jk,ji,je) = fbdata1%pext(jk,ji,je) 690 END DO 691 END DO 692 END DO 693 694 END SUBROUTINE copy_obfbdata 695 696 SUBROUTINE subsamp_obfbdata( fbdata1, fbdata2, llvalid ) 697 !!---------------------------------------------------------------------- 698 !! *** ROUTINE susbamp_obfbdata *** 699 !! 700 !! ** Purpose : Subsample an obfbdata structure based on the 701 !! logical mask. 702 !! 703 !! ** Method : Copy all data from fbdata1 to fbdata2 if 704 !! llvalid(obs)==true 705 !! 706 !! ** Action : 707 !! 708 !!---------------------------------------------------------------------- 709 !! * Arguments 710 TYPE(obfbdata) :: fbdata1 ! Input obsfbdata structure 711 TYPE(obfbdata) :: fbdata2 ! Output obsfbdata structure 712 LOGICAL, DIMENSION(fbdata1%nobs) :: llvalid ! Grid info on output file 713 !! * Local variables 714 INTEGER :: nobs 715 INTEGER :: jv 716 INTEGER :: je 717 INTEGER :: ji 718 INTEGER :: jk 719 INTEGER :: jq 720 INTEGER :: ij 721 722 ! Check allocation status of fbdata1 723 724 IF ( .NOT. fbdata1%lalloc ) THEN 725 CALL fatal_error( 'copy_obfbdata: input data not allocated', & 726 & __LINE__ ) 727 ENDIF 728 729 ! Check allocation status of fbdata2 and abort if already allocated 730 731 IF ( fbdata2%lalloc ) THEN 732 CALL fatal_error( 'subsample_obfbdata: ' // & 733 & 'fbdata2 already allocated', __LINE__ ) 734 ENDIF 735 736 ! Count number of subsampled observations 737 738 nobs = COUNT(llvalid) 739 740 ! Allocate new data structure 741 742 CALL alloc_obfbdata( fbdata2, fbdata1%nvar, nobs, & 743 & fbdata1%nlev, fbdata1%nadd, fbdata1%next, & 744 & fbdata1%lgrid, kqcf = fbdata1%nqcf ) 745 746 ! Copy the header data 747 748 fbdata2%cdjuldref = fbdata1%cdjuldref 749 750 ij = 0 751 DO ji = 1, fbdata1%nobs 752 IF ( llvalid(ji) ) THEN 753 ij = ij +1 754 fbdata2%cdwmo(ij) = fbdata1%cdwmo(ji) 755 fbdata2%cdtyp(ij) = fbdata1%cdtyp(ji) 756 fbdata2%ioqc(ij) = fbdata1%ioqc(ji) 757 fbdata2%ipqc(ij) = fbdata1%ipqc(ji) 758 fbdata2%itqc(ij) = fbdata1%itqc(ji) 759 fbdata2%plam(ij) = fbdata1%plam(ji) 760 fbdata2%pphi(ij) = fbdata1%pphi(ji) 761 fbdata2%ptim(ij) = fbdata1%ptim(ji) 762 fbdata2%kindex(ij) = fbdata1%kindex(ji) 763 DO jq = 1, fbdata1%nqcf 764 fbdata2%ioqcf(jq,ij) = fbdata1%ioqcf(jq,ji) 765 fbdata2%ipqcf(jq,ij) = fbdata1%ipqcf(jq,ji) 766 fbdata2%itqcf(jq,ij) = fbdata1%itqcf(jq,ji) 767 END DO 768 DO jk = 1, fbdata1%nlev 769 fbdata2%idqc(jk,ij) = fbdata1%idqc(jk,ji) 770 fbdata2%pdep(jk,ij) = fbdata1%pdep(jk,ji) 771 DO jq = 1, fbdata1%nqcf 772 fbdata2%idqcf(jq,jk,ij) = fbdata1%idqcf(jq,jk,ji) 773 END DO 774 END DO 775 ENDIF 776 END DO 777 778 ! Copy the variable data 779 780 DO jv = 1, fbdata1%nvar 781 fbdata2%cname(jv) = fbdata1%cname(jv) 782 fbdata2%coblong(jv) = fbdata1%coblong(jv) 783 fbdata2%cobunit(jv) = fbdata1%cobunit(jv) 784 ij = 0 785 DO ji = 1, fbdata1%nobs 786 IF ( llvalid(ji) ) THEN 787 ij = ij + 1 788 fbdata2%ivqc(ij,jv) = fbdata1%ivqc(ji,jv) 789 DO jq = 1, fbdata1%nqcf 790 fbdata2%ivqcf(jq,ij,jv) = fbdata1%ivqcf(jq,ji,jv) 791 END DO 792 DO jk = 1, fbdata1%nlev 793 fbdata2%ivlqc(jk,ij,jv) = fbdata1%ivlqc(jk,ji,jv) 794 fbdata2%pob(jk,ij,jv) = fbdata1%pob(jk,ji,jv) 795 DO jq = 1, fbdata1%nqcf 796 fbdata2%ivlqcf(jq,jk,ij,jv) = fbdata1%ivlqcf(jq,jk,ji,jv) 797 END DO 798 END DO 799 ENDIF 800 END DO 801 END DO 802 803 ! Copy grid information 804 805 IF ( fbdata1%lgrid ) THEN 806 DO jv = 1, fbdata1%nvar 807 fbdata2%cgrid(jv) = fbdata1%cgrid(jv) 808 ij = 0 809 DO ji = 1, fbdata1%nobs 810 IF ( llvalid(ji) ) THEN 811 ij = ij + 1 812 fbdata2%iproc(ij,jv) = fbdata1%iproc(ji,jv) 813 fbdata2%iobsi(ij,jv) = fbdata1%iobsi(ji,jv) 814 fbdata2%iobsj(ij,jv) = fbdata1%iobsj(ji,jv) 815 DO jk = 1, fbdata1%nlev 816 fbdata2%iobsk(jk,ij,jv) = fbdata1%iobsk(jk,ji,jv) 817 END DO 818 ENDIF 819 END DO 820 END DO 821 ENDIF 822 823 ! Copy additional information 824 825 DO je = 1, fbdata1%nadd 826 fbdata2%caddname(je) = fbdata1%caddname(je) 827 END DO 828 DO jv = 1, fbdata1%nvar 829 DO je = 1, fbdata1%nadd 830 fbdata2%caddlong(je,jv) = fbdata1%caddlong(je,jv) 831 fbdata2%caddunit(je,jv) = fbdata1%caddunit(je,jv) 832 ij = 0 833 DO ji = 1, fbdata1%nobs 834 IF ( llvalid(ji) ) THEN 835 ij = ij + 1 836 DO jk = 1, fbdata1%nlev 837 fbdata2%padd(jk,ij,je,jv) = fbdata1%padd(jk,ji,je,jv) 838 END DO 839 ENDIF 840 END DO 841 END DO 842 END DO 843 844 ! Copy extra information 845 846 DO je = 1, fbdata1%next 847 fbdata2%cextname(je) = fbdata1%cextname(je) 848 fbdata2%cextlong(je) = fbdata1%cextlong(je) 849 fbdata2%cextunit(je) = fbdata1%cextunit(je) 850 END DO 851 DO je = 1, fbdata1%next 852 ij = 0 853 DO ji = 1, fbdata1%nobs 854 IF ( llvalid(ji) ) THEN 855 ij = ij + 1 856 DO jk = 1, fbdata1%nlev 857 fbdata2%pext(jk,ij,je) = fbdata1%pext(jk,ji,je) 858 END DO 859 ENDIF 860 END DO 861 END DO 862 863 END SUBROUTINE subsamp_obfbdata 864 865 SUBROUTINE merge_obfbdata( nsets, fbdatain, fbdataout, iset, inum, iind ) 866 !!---------------------------------------------------------------------- 867 !! *** ROUTINE merge_obfbdata *** 868 !! 869 !! ** Purpose : Merge multiple obfbdata structures into an one. 870 !! 871 !! ** Method : The order of elements is based on the indices in 872 !! iind. 873 !! All input data are assumed to be consistent. This 874 !! is assumed to be checked before calling this routine. 875 !! Likewise output data is assume to be consistent as 876 !! well without error checking. 877 !! 878 !! ** Action : 879 !! 880 !!---------------------------------------------------------------------- 881 !! * Arguments 882 INTEGER, INTENT(IN):: nsets ! Number of input data sets 883 TYPE(obfbdata), DIMENSION(nsets) :: fbdatain ! Input obsfbdata structure 884 TYPE(obfbdata) :: fbdataout ! Output obsfbdata structure 885 INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & 886 & iset ! Set number for a given obs. 887 INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & 888 & inum ! Number within set for an obs 889 INTEGER, INTENT(IN), DIMENSION(fbdataout%nobs) :: & 890 & iind ! Indices for copying. 891 !! * Local variables 892 893 INTEGER :: js 894 INTEGER :: jo 895 INTEGER :: jv 896 INTEGER :: je 897 INTEGER :: ji 898 INTEGER :: jk 899 INTEGER :: jq 900 901 ! Check allocation status of fbdatain 902 903 DO js = 1, nsets 904 IF ( .NOT. fbdatain(js)%lalloc ) THEN 905 CALL fatal_error( 'merge_obfbdata: input data not allocated', & 906 & __LINE__ ) 907 ENDIF 908 END DO 909 910 ! Check allocation status of fbdataout 911 912 IF ( .NOT.fbdataout%lalloc ) THEN 913 CALL fatal_error( 'merge_obfbdata: output data not allocated', & 914 & __LINE__ ) 915 ENDIF 916 917 ! Merge various names 918 919 DO jv = 1, fbdatain(1)%nvar 920 fbdataout%cname(jv) = fbdatain(1)%cname(jv) 921 fbdataout%coblong(jv) = fbdatain(1)%coblong(jv) 922 fbdataout%cobunit(jv) = fbdatain(1)%cobunit(jv) 923 IF ( fbdatain(1)%lgrid ) THEN 924 fbdataout%cgrid(jv) = fbdatain(1)%cgrid(jv) 925 ENDIF 926 END DO 927 DO jv = 1, fbdatain(1)%nadd 928 fbdataout%caddname(jv) = fbdatain(1)%caddname(jv) 929 END DO 930 DO jv = 1, fbdatain(1)%nvar 931 DO je = 1, fbdatain(1)%nadd 932 fbdataout%caddlong(je,jv) = fbdatain(1)%caddlong(je,jv) 933 fbdataout%caddunit(je,jv) = fbdatain(1)%caddunit(je,jv) 934 END DO 935 END DO 936 DO jv = 1, fbdatain(1)%next 937 fbdataout%cextname(jv) = fbdatain(1)%cextname(jv) 938 fbdataout%cextlong(jv) = fbdatain(1)%cextlong(jv) 939 fbdataout%cextunit(jv) = fbdatain(1)%cextunit(jv) 940 END DO 941 fbdataout%cdjuldref = fbdatain(1)%cdjuldref 942 943 ! Loop over total views 944 945 DO jo = 1, fbdataout%nobs 946 947 js = iset(iind(jo)) 948 ji = inum(iind(jo)) 949 950 ! Merge the header data 951 952 fbdataout%cdwmo(jo) = fbdatain(js)%cdwmo(ji) 953 fbdataout%cdtyp(jo) = fbdatain(js)%cdtyp(ji) 954 fbdataout%ioqc(jo) = fbdatain(js)%ioqc(ji) 955 fbdataout%ipqc(jo) = fbdatain(js)%ipqc(ji) 956 fbdataout%itqc(jo) = fbdatain(js)%itqc(ji) 957 fbdataout%plam(jo) = fbdatain(js)%plam(ji) 958 fbdataout%pphi(jo) = fbdatain(js)%pphi(ji) 959 fbdataout%ptim(jo) = fbdatain(js)%ptim(ji) 960 fbdataout%kindex(jo) = fbdatain(js)%kindex(ji) 961 DO jq = 1, fbdatain(js)%nqcf 962 fbdataout%ioqcf(jq,jo) = fbdatain(js)%ioqcf(jq,ji) 963 fbdataout%ipqcf(jq,jo) = fbdatain(js)%ipqcf(jq,ji) 964 fbdataout%itqcf(jq,jo) = fbdatain(js)%itqcf(jq,ji) 965 END DO 966 DO jk = 1, fbdatain(js)%nlev 967 fbdataout%pdep(jk,jo) = fbdatain(js)%pdep(jk,ji) 968 fbdataout%idqc(jk,jo) = fbdatain(js)%idqc(jk,ji) 969 DO jq = 1, fbdatain(js)%nqcf 970 fbdataout%idqcf(jq,jk,jo) = fbdatain(js)%idqcf(jq,jk,ji) 971 END DO 972 END DO 973 974 ! Merge the variable data 975 976 DO jv = 1, fbdatain(js)%nvar 977 fbdataout%ivqc(jo,jv) = fbdatain(js)%ivqc(ji,jv) 978 DO jq = 1, fbdatain(js)%nqcf 979 fbdataout%ivqcf(jq,jo,jv) = fbdatain(js)%ivqcf(jq,ji,jv) 980 END DO 981 DO jk = 1, fbdatain(js)%nlev 982 fbdataout%ivlqc(jk,jo,jv) = fbdatain(js)%ivlqc(jk,ji,jv) 983 fbdataout%pob(jk,jo,jv) = fbdatain(js)%pob(jk,ji,jv) 984 DO jq = 1, fbdatain(js)%nqcf 985 fbdataout%ivlqcf(jq,jk,jo,jv) = & 986 & fbdatain(js)%ivlqcf(jq,jk,ji,jv) 987 END DO 988 END DO 989 END DO 990 991 ! Merge grid information 992 993 IF ( fbdatain(js)%lgrid ) THEN 994 DO jv = 1, fbdatain(js)%nvar 995 fbdataout%cgrid(jv) = fbdatain(js)%cgrid(jv) 996 fbdataout%iproc(jo,jv) = fbdatain(js)%iproc(ji,jv) 997 fbdataout%iobsi(jo,jv) = fbdatain(js)%iobsi(ji,jv) 998 fbdataout%iobsj(jo,jv) = fbdatain(js)%iobsj(ji,jv) 999 DO jk = 1, fbdatain(js)%nlev 1000 fbdataout%iobsk(jk,jo,jv) = fbdatain(js)%iobsk(jk,ji,jv) 1001 END DO 1002 END DO 1003 ENDIF 1004 1005 ! Merge additional information 1006 1007 DO jv = 1, fbdatain(js)%nvar 1008 DO je = 1, fbdatain(js)%nadd 1009 DO jk = 1, fbdatain(js)%nlev 1010 fbdataout%padd(jk,jo,je,jv) = fbdatain(js)%padd(jk,ji,je,jv) 1011 END DO 1012 END DO 1013 END DO 1014 1015 ! Merge extra information 1016 1017 DO je = 1, fbdatain(js)%next 1018 DO jk = 1, fbdatain(js)%nlev 1019 fbdataout%pext(jk,jo,je) = fbdatain(js)%pext(jk,ji,je) 1020 END DO 1021 END DO 1022 1023 END DO 1024 1025 END SUBROUTINE merge_obfbdata 1026 1027 SUBROUTINE write_obfbdata( cdfilename, fbdata ) 1028 !!---------------------------------------------------------------------- 1029 !! *** ROUTINE write_obfbdata *** 1030 !! 1031 !! ** Purpose : Write an obfbdata structure into a netCDF file. 1032 !! 1033 !! ** Method : 1034 !! 1035 !! ** Action : 1036 !! 1037 !!---------------------------------------------------------------------- 1038 !! * Arguments 1039 CHARACTER(len=*) :: cdfilename ! Output filename 1040 TYPE(obfbdata) :: fbdata ! obsfbdata structure 1041 !! * Local variables 1042 CHARACTER(LEN=14), PARAMETER :: cpname = 'write_obfbdata' 1043 ! Dimension ids 1044 INTEGER :: idfile 1045 INTEGER :: idodim 1046 INTEGER :: idldim 1047 INTEGER :: idvdim 1048 INTEGER :: idadim 1049 INTEGER :: idedim 1050 INTEGER :: idsndim 1051 INTEGER :: idsgdim 1052 INTEGER :: idswdim 1053 INTEGER :: idstdim 1054 INTEGER :: idjddim 1055 INTEGER :: idqcdim 1056 INTEGER :: idvard 1057 INTEGER :: idaddd 1058 INTEGER :: idextd 1059 INTEGER :: idcdwmo 1060 INTEGER :: idcdtyp 1061 INTEGER :: idplam 1062 INTEGER :: idpphi 1063 INTEGER :: idpdep 1064 INTEGER :: idptim 1065 INTEGER :: idptimr 1066 INTEGER :: idioqc 1067 INTEGER :: idioqcf 1068 INTEGER :: idipqc 1069 INTEGER :: idipqcf 1070 INTEGER :: iditqc 1071 INTEGER :: iditqcf 1072 INTEGER :: ididqc 1073 INTEGER :: ididqcf 1074 INTEGER :: idkindex 1075 INTEGER, DIMENSION(fbdata%nvar) :: & 1076 & idpob, & 1077 & idivqc, & 1078 & idivqcf, & 1079 & idivlqc, & 1080 & idivlqcf, & 1081 & idiobsi, & 1082 & idiobsj, & 1083 & idiobsk, & 1084 & idcgrid 1085 INTEGER, DIMENSION(fbdata%nadd,fbdata%nvar) :: idpadd 1086 INTEGER, DIMENSION(fbdata%next) :: idpext 1087 INTEGER, DIMENSION(1) :: incdim1 1088 INTEGER, DIMENSION(2) :: incdim2 1089 INTEGER, DIMENSION(3) :: incdim3 1090 INTEGER, DIMENSION(4) :: incdim4 1091 1092 INTEGER :: jv 1093 INTEGER :: je 1094 INTEGER :: ioldfill 1095 CHARACTER(len=nf90_max_name) :: & 1096 & cdtmp 1097 CHARACTER(len=16), PARAMETER :: & 1098 & cdqcconv = 'q where q =[0,9]' 1099 CHARACTER(len=24), PARAMETER :: & 1100 & cdqcfconv = 'NEMOVAR flag conventions' 1101 CHARACTER(len=ilenlong) :: & 1102 & cdltmp 1103 1104 ! Open output filename 1105 1106 CALL chkerr( nf90_create( TRIM( cdfilename ), nf90_clobber, idfile ), & 1107 & cpname, __LINE__ ) 1108 CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), & 1109 & cpname, __LINE__ ) 1110 CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & 1111 & 'NEMO observation operator output' ), & 1112 & cpname, __LINE__ ) 1113 CALL chkerr( nf90_put_att( idfile, nf90_global, 'Convention', & 1114 & 'NEMO unified observation operator output' ),& 1115 & cpname,__LINE__ ) 1116 1117 ! Create the dimensions 1118 1119 CALL chkerr( nf90_def_dim( idfile, 'N_OBS' , fbdata%nobs, idodim ), & 1120 & cpname,__LINE__ ) 1121 CALL chkerr( nf90_def_dim( idfile, 'N_LEVELS', fbdata%nlev, idldim ), & 1122 & cpname,__LINE__ ) 1123 CALL chkerr( nf90_def_dim( idfile, 'N_VARS', fbdata%nvar, idvdim ), & 1124 & cpname,__LINE__ ) 1125 CALL chkerr( nf90_def_dim( idfile, 'N_QCF', fbdata%nqcf, idqcdim ),& 1126 & cpname,__LINE__ ) 1127 IF ( fbdata%nadd > 0 ) THEN 1128 CALL chkerr( nf90_def_dim( idfile, 'N_ENTRIES', fbdata%nadd, idadim ), & 1129 & cpname,__LINE__ ) 1130 ENDIF 1131 IF ( fbdata%next > 0 ) THEN 1132 CALL chkerr( nf90_def_dim( idfile, 'N_EXTRA', fbdata%next, idedim ), & 1133 & cpname,__LINE__ ) 1134 ENDIF 1135 CALL chkerr( nf90_def_dim( idfile, 'STRINGNAM', ilenname, idsndim ), & 1136 & cpname,__LINE__ ) 1137 IF (fbdata%lgrid) THEN 1138 CALL chkerr( nf90_def_dim( idfile, 'STRINGGRID', ilengrid, idsgdim ),& 1139 & cpname,__LINE__ ) 1140 ENDIF 1141 CALL chkerr( nf90_def_dim( idfile, 'STRINGWMO', ilenwmo, idswdim ), & 1142 & cpname,__LINE__ ) 1143 CALL chkerr( nf90_def_dim( idfile, 'STRINGTYP', ilentyp, idstdim ), & 1144 & cpname,__LINE__ ) 1145 CALL chkerr( nf90_def_dim( idfile, 'STRINGJULD', ilenjuld, idjddim ), & 1146 & cpname,__LINE__ ) 1147 1148 ! Define netCDF variables for header information 1149 1150 incdim2(1) = idsndim 1151 incdim2(2) = idvdim 1152 1153 CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, & 1154 & idvard ), cpname, __LINE__ ) 1155 CALL putvaratt_obfbdata( idfile, idvard, & 1156 & 'List of variables in feedback files' ) 1157 1158 IF ( fbdata%nadd > 0 ) THEN 1159 incdim2(1) = idsndim 1160 incdim2(2) = idadim 1161 CALL chkerr( nf90_def_var( idfile, 'ENTRIES', nf90_char, incdim2, & 1162 & idaddd ), cpname, __LINE__ ) 1163 CALL putvaratt_obfbdata( idfile, idaddd, & 1164 & 'List of additional entries for each '// & 1165 & 'variable in feedback files' ) 1166 ENDIF 1167 1168 IF ( fbdata%next > 0 ) THEN 1169 incdim2(1) = idsndim 1170 incdim2(2) = idedim 1171 CALL chkerr( nf90_def_var( idfile, 'EXTRA', nf90_char, incdim2, & 1172 & idextd ), cpname, __LINE__ ) 1173 CALL putvaratt_obfbdata( idfile, idextd, & 1174 & 'List of extra variables' ) 1175 ENDIF 1176 1177 incdim2(1) = idswdim 1178 incdim2(2) = idodim 1179 CALL chkerr( nf90_def_var( idfile, 'STATION_IDENTIFIER', & 1180 & nf90_char, incdim2, & 1181 & idcdwmo ), cpname, __LINE__ ) 1182 CALL putvaratt_obfbdata( idfile, idcdwmo, & 1183 & 'Station identifier' ) 1184 incdim2(1) = idstdim 1185 incdim2(2) = idodim 1186 CALL chkerr( nf90_def_var( idfile, 'STATION_TYPE', & 1187 & nf90_char, incdim2, & 1188 & idcdtyp ), cpname, __LINE__ ) 1189 CALL putvaratt_obfbdata( idfile, idcdtyp, & 1190 & 'Code instrument type' ) 1191 incdim1(1) = idodim 1192 CALL chkerr( nf90_def_var( idfile, 'LONGITUDE', & 1193 & nf90_double, incdim1, & 1194 & idplam ), cpname, __LINE__ ) 1195 CALL putvaratt_obfbdata( idfile, idplam, & 1196 & 'Longitude', cdunits = 'degrees_east', & 1197 & rfillvalue = fbrmdi ) 1198 CALL chkerr( nf90_def_var( idfile, 'LATITUDE', & 1199 & nf90_double, incdim1, & 1200 & idpphi ), cpname, __LINE__ ) 1201 CALL putvaratt_obfbdata( idfile, idpphi, & 1202 & 'Latitude', cdunits = 'degrees_north', & 1203 & rfillvalue = fbrmdi ) 1204 incdim2(1) = idldim 1205 incdim2(2) = idodim 1206 CALL chkerr( nf90_def_var( idfile, 'DEPTH', & 1207 & nf90_double, incdim2, & 1208 & idpdep ), cpname, __LINE__ ) 1209 CALL putvaratt_obfbdata( idfile, idpdep, & 1210 & 'Depth', cdunits = 'metre', & 1211 & rfillvalue = fbrmdi ) 1212 incdim3(1) = idqcdim 1213 incdim3(2) = idldim 1214 incdim3(3) = idodim 1215 CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC', & 1216 & nf90_int, incdim2, & 1217 & ididqc ), cpname, __LINE__ ) 1218 CALL putvaratt_obfbdata( idfile, ididqc, & 1219 & 'Quality on depth', & 1220 & conventions = cdqcconv, & 1221 & ifillvalue = 0 ) 1222 CALL chkerr( nf90_def_var( idfile, 'DEPTH_QC_FLAGS', & 1223 & nf90_int, incdim3, & 1224 & ididqcf ), cpname, __LINE__ ) 1225 CALL putvaratt_obfbdata( idfile, ididqcf, & 1226 & 'Quality flags on depth', & 1227 & conventions = cdqcfconv ) 1228 CALL chkerr( nf90_def_var( idfile, 'JULD', & 1229 & nf90_double, incdim1, & 1230 & idptim ), cpname, __LINE__ ) 1231 CALL putvaratt_obfbdata( idfile, idptim, & 1232 & 'Julian day', & 1233 & cdunits = 'days since JULD_REFERENCE', & 1234 & conventions = 'relative julian days with '// & 1235 & 'decimal part (as parts of day)', & 1236 & rfillvalue = fbrmdi ) 1237 incdim1(1) = idjddim 1238 CALL chkerr( nf90_def_var( idfile, 'JULD_REFERENCE', & 1239 & nf90_char, incdim1, & 1240 & idptimr ), cpname, __LINE__ ) 1241 CALL putvaratt_obfbdata( idfile, idptimr, & 1242 & 'Date of reference for julian days ', & 1243 & conventions = 'YYYYMMDDHHMMSS' ) 1244 incdim1(1) = idodim 1245 CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC', & 1246 & nf90_int, incdim1, & 1247 & idioqc ), cpname, __LINE__ ) 1248 CALL putvaratt_obfbdata( idfile, idioqc, & 1249 & 'Quality on observation', & 1250 & conventions = cdqcconv, & 1251 & ifillvalue = 0 ) 1252 incdim2(1) = idqcdim 1253 incdim2(2) = idodim 1254 CALL chkerr( nf90_def_var( idfile, 'OBSERVATION_QC_FLAGS', & 1255 & nf90_int, incdim2, & 1256 & idioqcf ), cpname, __LINE__ ) 1257 CALL putvaratt_obfbdata( idfile, idioqcf, & 1258 & 'Quality flags on observation', & 1259 & conventions = cdqcfconv, & 1260 & ifillvalue = 0 ) 1261 CALL chkerr( nf90_def_var( idfile, 'POSITION_QC', & 1262 & nf90_int, incdim1, & 1263 & idipqc ), cpname, __LINE__ ) 1264 CALL putvaratt_obfbdata( idfile, idipqc, & 1265 & 'Quality on position (latitude and longitude)', & 1266 & conventions = cdqcconv, & 1267 & ifillvalue = 0 ) 1268 CALL chkerr( nf90_def_var( idfile, 'POSITION_QC_FLAGS', & 1269 & nf90_int, incdim2, & 1270 & idipqcf ), cpname, __LINE__ ) 1271 CALL putvaratt_obfbdata( idfile, idipqcf, & 1272 & 'Quality flags on position', & 1273 & conventions = cdqcfconv, & 1274 & ifillvalue = 0 ) 1275 CALL chkerr( nf90_def_var( idfile, 'JULD_QC', & 1276 & nf90_int, incdim1, & 1277 & iditqc ), cpname, __LINE__ ) 1278 CALL putvaratt_obfbdata( idfile, iditqc, & 1279 & 'Quality on date and time', & 1280 & conventions = cdqcconv, & 1281 & ifillvalue = 0 ) 1282 CALL chkerr( nf90_def_var( idfile, 'JULD_QC_FLAGS', & 1283 & nf90_int, incdim2, & 1284 & iditqcf ), cpname, __LINE__ ) 1285 CALL putvaratt_obfbdata( idfile, iditqcf, & 1286 & 'Quality flags on date and time', & 1287 & conventions = cdqcfconv, & 1288 & ifillvalue = 0 ) 1289 CALL chkerr( nf90_def_var( idfile, 'ORIGINAL_FILE_INDEX', & 1290 & nf90_int, incdim1, & 1291 & idkindex ), cpname, __LINE__ ) 1292 CALL putvaratt_obfbdata( idfile, idkindex, & 1293 & 'Index in original data file', & 1294 & ifillvalue = fbimdi ) 1295 1296 ! Define netCDF variables for individual variables 1297 1298 DO jv = 1, fbdata%nvar 1299 1300 incdim1(1) = idodim 1301 incdim2(1) = idldim 1302 incdim2(2) = idodim 1303 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' 1304 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & 1305 & incdim2, idpob(jv) ), & 1306 & cpname, __LINE__ ) 1307 CALL putvaratt_obfbdata( idfile, idpob(jv), & 1308 & fbdata%coblong(jv), & 1309 & cdunits = fbdata%cobunit(jv), & 1310 & rfillvalue = fbrmdi ) 1311 1312 IF ( fbdata%nadd > 0 ) THEN 1313 DO je = 1, fbdata%nadd 1314 WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& 1315 & TRIM(fbdata%caddname(je)) 1316 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & 1317 & incdim2, idpadd(je,jv) ), & 1318 & cpname, __LINE__ ) 1319 CALL putvaratt_obfbdata( idfile, idpadd(je,jv), & 1320 & fbdata%caddlong(je,jv), & 1321 & cdunits = fbdata%caddunit(je,jv), & 1322 & rfillvalue = fbrmdi ) 1323 END DO 1324 ENDIF 1325 1326 cdltmp = fbdata%coblong(jv) 1327 IF (( cdltmp(1:1) >= 'A' ).AND.( cdltmp(1:1) <= 'Z' )) & 1328 & cdltmp(1:1) = ACHAR(IACHAR(cdltmp(1:1)) + 32) 1329 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC' 1330 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1331 & incdim1, idivqc(jv) ), & 1332 & cpname, __LINE__ ) 1333 CALL putvaratt_obfbdata( idfile, idivqc(jv), & 1334 & 'Quality on '//cdltmp, & 1335 & conventions = cdqcconv, & 1336 & ifillvalue = 0 ) 1337 incdim2(1) = idqcdim 1338 incdim2(2) = idodim 1339 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' 1340 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1341 & incdim2, idivqcf(jv) ), & 1342 & cpname, __LINE__ ) 1343 CALL putvaratt_obfbdata( idfile, idivqcf(jv), & 1344 & 'Quality flags on '//cdltmp, & 1345 & conventions = cdqcfconv, & 1346 & ifillvalue = 0 ) 1347 incdim2(1) = idldim 1348 incdim2(2) = idodim 1349 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' 1350 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1351 & incdim2, idivlqc(jv) ), & 1352 & cpname, __LINE__ ) 1353 CALL putvaratt_obfbdata( idfile, idivlqc(jv), & 1354 & 'Quality for each level on '//cdltmp, & 1355 & conventions = cdqcconv, & 1356 & ifillvalue = 0 ) 1357 incdim3(1) = idqcdim 1358 incdim3(2) = idldim 1359 incdim3(3) = idodim 1360 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' 1361 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1362 & incdim3, idivlqcf(jv) ), & 1363 & cpname, __LINE__ ) 1364 CALL putvaratt_obfbdata( idfile, idivlqcf(jv), & 1365 & 'Quality flags for each level on '//& 1366 & cdltmp, & 1367 & conventions = cdqcfconv, & 1368 & ifillvalue = 0 ) 1369 1370 IF (fbdata%lgrid) THEN 1371 incdim2(1) = idldim 1372 incdim2(2) = idodim 1373 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' 1374 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1375 & incdim1, idiobsi(jv) ), & 1376 & cpname, __LINE__ ) 1377 CALL putvaratt_obfbdata( idfile, idiobsi(jv), & 1378 & 'ORCA grid search I coordinate') 1379 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' 1380 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1381 & incdim1, idiobsj(jv) ), & 1382 & cpname, __LINE__ ) 1383 CALL putvaratt_obfbdata( idfile, idiobsj(jv), & 1384 & 'ORCA grid search J coordinate') 1385 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' 1386 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_int, & 1387 & incdim2, idiobsk(jv) ), & 1388 & cpname, __LINE__ ) 1389 CALL putvaratt_obfbdata( idfile, idiobsk(jv), & 1390 & 'ORCA grid search K coordinate') 1391 incdim1(1) = idsgdim 1392 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' 1393 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_char, incdim1, & 1394 & idcgrid(jv) ), cpname, __LINE__ ) 1395 CALL putvaratt_obfbdata( idfile, idcgrid(jv), & 1396 & 'ORCA grid search grid (T,U,V)') 1397 ENDIF 1398 1399 END DO 1400 1401 IF ( fbdata%next > 0 ) THEN 1402 DO je = 1, fbdata%next 1403 incdim2(1) = idldim 1404 incdim2(2) = idodim 1405 WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) 1406 CALL chkerr( nf90_def_var( idfile, cdtmp, nf90_float, & 1407 & incdim2, idpext(je) ), & 1408 & cpname, __LINE__ ) 1409 CALL putvaratt_obfbdata( idfile, idpext(je), & 1410 & fbdata%cextlong(je), & 1411 & cdunits = fbdata%cextunit(je), & 1412 & rfillvalue = fbrmdi ) 1413 END DO 1414 ENDIF 1415 1416 ! Stop definitions 1417 1418 CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ ) 1419 1420 ! Write the variables 1421 1422 CALL chkerr( nf90_put_var( idfile, idvard, fbdata%cname ), & 1423 & cpname, __LINE__ ) 1424 1425 IF ( fbdata%nadd > 0 ) THEN 1426 CALL chkerr( nf90_put_var( idfile, idaddd, fbdata%caddname ), & 1427 & cpname, __LINE__ ) 1428 ENDIF 1429 1430 IF ( fbdata%next > 0 ) THEN 1431 CALL chkerr( nf90_put_var( idfile, idextd, fbdata%cextname ), & 1432 & cpname, __LINE__ ) 1433 ENDIF 1434 1435 CALL chkerr( nf90_put_var( idfile, idptimr, fbdata%cdjuldref ), & 1436 & cpname, __LINE__ ) 1437 1438 ! Only write the data if observation is available 1439 1440 IF ( fbdata%nobs > 0 ) THEN 1441 1442 CALL chkerr( nf90_put_var( idfile, idcdwmo, fbdata%cdwmo ), & 1443 & cpname, __LINE__ ) 1444 CALL chkerr( nf90_put_var( idfile, idcdtyp, fbdata%cdtyp ), & 1445 & cpname, __LINE__ ) 1446 CALL chkerr( nf90_put_var( idfile, idplam, fbdata%plam ), & 1447 & cpname, __LINE__ ) 1448 CALL chkerr( nf90_put_var( idfile, idpphi, fbdata%pphi ), & 1449 & cpname, __LINE__ ) 1450 CALL chkerr( nf90_put_var( idfile, idpdep, fbdata%pdep ), & 1451 & cpname, __LINE__ ) 1452 CALL chkerr( nf90_put_var( idfile, idptim, fbdata%ptim ), & 1453 & cpname, __LINE__ ) 1454 CALL chkerr( nf90_put_var( idfile, idioqc, fbdata%ioqc ), & 1455 & cpname, __LINE__ ) 1456 CALL chkerr( nf90_put_var( idfile, idioqcf, fbdata%ioqcf ), & 1457 & cpname, __LINE__ ) 1458 CALL chkerr( nf90_put_var( idfile, idipqc, fbdata%ipqc ), & 1459 & cpname, __LINE__ ) 1460 CALL chkerr( nf90_put_var( idfile, idipqcf, fbdata%ipqcf ), & 1461 & cpname, __LINE__ ) 1462 CALL chkerr( nf90_put_var( idfile, iditqc, fbdata%itqc ), & 1463 & cpname, __LINE__ ) 1464 CALL chkerr( nf90_put_var( idfile, iditqcf, fbdata%itqcf ), & 1465 & cpname, __LINE__ ) 1466 CALL chkerr( nf90_put_var( idfile, ididqc, fbdata%idqc ), & 1467 & cpname, __LINE__ ) 1468 CALL chkerr( nf90_put_var( idfile, ididqcf, fbdata%idqcf ), & 1469 & cpname, __LINE__ ) 1470 CALL chkerr( nf90_put_var( idfile, idkindex, fbdata%kindex ), & 1471 & cpname, __LINE__ ) 1472 1473 DO jv = 1, fbdata%nvar 1474 CALL chkerr( nf90_put_var( idfile, idpob(jv), fbdata%pob(:,:,jv) ), & 1475 & cpname, __LINE__ ) 1476 IF ( fbdata%nadd > 0 ) THEN 1477 DO je = 1, fbdata%nadd 1478 CALL chkerr( nf90_put_var( idfile, idpadd(je,jv), & 1479 & fbdata%padd(:,:,je,jv) ), & 1480 & cpname, __LINE__ ) 1481 END DO 1482 ENDIF 1483 CALL chkerr( nf90_put_var( idfile, idivqc(jv), & 1484 & fbdata%ivqc(:,jv) ),& 1485 & cpname, __LINE__ ) 1486 CALL chkerr( nf90_put_var( idfile, idivqcf(jv), & 1487 & fbdata%ivqcf(:,:,jv) ),& 1488 & cpname, __LINE__ ) 1489 CALL chkerr( nf90_put_var( idfile, idivlqc(jv), & 1490 & fbdata%ivlqc(:,:,jv) ),& 1491 & cpname, __LINE__ ) 1492 CALL chkerr( nf90_put_var( idfile, idivlqcf(jv), & 1493 & fbdata%ivlqcf(:,:,:,jv) ),& 1494 & cpname, __LINE__ ) 1495 IF (fbdata%lgrid) THEN 1496 CALL chkerr( nf90_put_var( idfile, idiobsi(jv), & 1497 & fbdata%iobsi(:,jv) ),& 1498 & cpname, __LINE__ ) 1499 CALL chkerr( nf90_put_var( idfile, idiobsj(jv), & 1500 & fbdata%iobsj(:,jv) ),& 1501 & cpname, __LINE__ ) 1502 CALL chkerr( nf90_put_var( idfile, idiobsk(jv), & 1503 & fbdata%iobsk(:,:,jv) ),& 1504 & cpname, __LINE__ ) 1505 CALL chkerr( nf90_put_var( idfile, idcgrid(jv), & 1506 & fbdata%cgrid(jv) ), & 1507 & cpname, __LINE__ ) 1508 ENDIF 1509 END DO 1510 1511 IF ( fbdata%next > 0 ) THEN 1512 DO je = 1, fbdata%next 1513 CALL chkerr( nf90_put_var( idfile, idpext(je), & 1514 & fbdata%pext(:,:,je) ), & 1515 & cpname, __LINE__ ) 1516 END DO 1517 ENDIF 1518 1519 ENDIF 1520 1521 ! Close the file 1522 1523 CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) 1524 1525 1526 END SUBROUTINE write_obfbdata 1527 1528 SUBROUTINE putvaratt_obfbdata( idfile, idvar, cdlongname, cdunits, & 1529 & conventions, cfillvalue, & 1530 & ifillvalue, rfillvalue ) 1531 !!---------------------------------------------------------------------- 1532 !! *** ROUTINE putvaratt_obfbdata *** 1533 !! 1534 !! ** Purpose : Write netcdf attributes for variable 1535 !! 1536 !! ** Method : 1537 !! 1538 !! ** Action : 1539 !! 1540 !!---------------------------------------------------------------------- 1541 !! * Arguments 1542 INTEGER :: idfile ! File netcdf id. 1543 INTEGER :: idvar ! Variable netcdf id. 1544 CHARACTER(len=*) :: cdlongname ! Long name for variable 1545 CHARACTER(len=*), OPTIONAL :: cdunits ! Units for variable 1546 CHARACTER(len=*), OPTIONAL :: cfillvalue ! Fill value for character variables 1547 INTEGER, OPTIONAL :: ifillvalue ! Fill value for integer variables 1548 REAL(kind=fbsp), OPTIONAL :: rfillvalue ! Fill value for real variables 1549 CHARACTER(len=*), OPTIONAL :: conventions ! Conventions for variable 1550 !! * Local variables 1551 CHARACTER(LEN=18), PARAMETER :: & 1552 & cpname = 'putvaratt_obfbdata' 1553 1554 CALL chkerr( nf90_put_att( idfile, idvar, 'long_name', & 1555 & TRIM(cdlongname) ), & 1556 & cpname, __LINE__ ) 1557 1558 IF ( PRESENT(cdunits) ) THEN 1559 1560 CALL chkerr( nf90_put_att( idfile, idvar, 'units', & 1561 & TRIM(cdunits) ), & 1562 & cpname, __LINE__ ) 1563 1564 ENDIF 1565 1566 IF ( PRESENT(conventions) ) THEN 1567 1568 CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', & 1569 & TRIM(conventions) ), & 1570 & cpname, __LINE__ ) 1571 1572 ENDIF 1573 1574 IF ( PRESENT(cfillvalue) ) THEN 1575 1576 CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & 1577 & TRIM(cfillvalue) ), & 1578 & cpname, __LINE__ ) 1579 1580 ENDIF 1581 1582 IF ( PRESENT(ifillvalue) ) THEN 1583 1584 CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & 1585 & ifillvalue ), & 1586 & cpname, __LINE__ ) 1587 1588 ENDIF 1589 1590 IF ( PRESENT(rfillvalue) ) THEN 1591 1592 CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & 1593 & rfillvalue ), & 1594 & cpname, __LINE__ ) 1595 1596 ENDIF 1597 1598 END SUBROUTINE putvaratt_obfbdata 1599 1600 SUBROUTINE read_obfbdata( cdfilename, fbdata, ldgrid ) 1601 !!---------------------------------------------------------------------- 1602 !! *** ROUTINE read_obfbdata *** 1603 !! 1604 !! ** Purpose : Read an obfbdata structure from a netCDF file. 1605 !! 1606 !! ** Method : 1607 !! 1608 !! ** Action : 1609 !! 1610 !!---------------------------------------------------------------------- 1611 !! * Arguments 1612 CHARACTER(len=*) :: cdfilename ! Input filename 1613 TYPE(obfbdata) :: fbdata ! obsfbdata structure 1614 LOGICAL, OPTIONAL :: ldgrid ! Allow forcing of grid info 1615 !! * Local variables 1616 CHARACTER(LEN=14), PARAMETER :: cpname = 'read_obfbdata' 1617 INTEGER :: idfile 1618 INTEGER :: idodim 1619 INTEGER :: idldim 1620 INTEGER :: idvdim 1621 INTEGER :: idadim 1622 INTEGER :: idedim 1623 INTEGER :: idgdim 1624 INTEGER :: idvard 1625 INTEGER :: idaddd 1626 INTEGER :: idextd 1627 INTEGER :: idcdwmo 1628 INTEGER :: idcdtyp 1629 INTEGER :: idplam 1630 INTEGER :: idpphi 1631 INTEGER :: idpdep 1632 INTEGER :: idptim 1633 INTEGER :: idptimr 1634 INTEGER :: idioqc 1635 INTEGER :: idioqcf 1636 INTEGER :: idipqc 1637 INTEGER :: idipqcf 1638 INTEGER :: ididqc 1639 INTEGER :: ididqcf 1640 INTEGER :: iditqc 1641 INTEGER :: iditqcf 1642 INTEGER :: idkindex 1643 INTEGER, DIMENSION(:), ALLOCATABLE :: & 1644 & idpob, & 1645 & idivqc, & 1646 & idivqcf, & 1647 & idivlqc, & 1648 & idivlqcf, & 1649 & idiobsi, & 1650 & idiobsj, & 1651 & idiobsk, & 1652 & idcgrid, & 1653 & idpext 1654 INTEGER, DIMENSION(:,:), ALLOCATABLE :: & 1655 & idpadd 1656 INTEGER :: jv 1657 INTEGER :: je 1658 INTEGER :: nvar 1659 INTEGER :: nobs 1660 INTEGER :: nlev 1661 INTEGER :: nadd 1662 INTEGER :: next 1663 LOGICAL :: lgrid 1664 CHARACTER(len=NF90_MAX_NAME) :: cdtmp 1665 1666 ! Check allocation status and deallocate previous allocated structures 1667 1668 IF ( fbdata%lalloc ) THEN 1669 CALL dealloc_obfbdata( fbdata ) 1670 ENDIF 1671 1672 ! Open input filename 1673 1674 CALL chkerr( nf90_open( TRIM( cdfilename ), nf90_nowrite, idfile ), & 1675 & cpname, __LINE__ ) 1676 1677 ! Get input dimensions 1678 1679 CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS' , idodim ), & 1680 & cpname,__LINE__ ) 1681 CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), & 1682 & cpname,__LINE__ ) 1683 CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), & 1684 & cpname,__LINE__ ) 1685 CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), & 1686 & cpname,__LINE__ ) 1687 CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), & 1688 & cpname,__LINE__ ) 1689 CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), & 1690 & cpname,__LINE__ ) 1691 IF ( nf90_inq_dimid( idfile, 'N_ENTRIES', idadim ) == 0 ) THEN 1692 CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), & 1693 & cpname,__LINE__ ) 1694 ELSE 1695 nadd = 0 1696 ENDIF 1697 IF ( nf90_inq_dimid( idfile, 'N_EXTRA', idedim ) == 0 ) THEN 1698 CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), & 1699 & cpname,__LINE__ ) 1700 ELSE 1701 next = 0 1702 ENDIF 1703 ! 1704 ! Check if this input file contains grid search informations 1705 ! 1706 lgrid = ( nf90_inq_dimid( idfile, 'STRINGGRID', idgdim ) == 0 ) 1707 1708 ! Allocate data structure 1709 1710 IF ( PRESENT(ldgrid) ) THEN 1711 CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, & 1712 & lgrid.OR.ldgrid ) 1713 ELSE 1714 CALL alloc_obfbdata( fbdata, nvar, nobs, nlev, nadd, next, & 1715 & lgrid ) 1716 ENDIF 1717 1718 ! Allocate netcdf identifiers 1719 1720 ALLOCATE( & 1721 & idpob(fbdata%nvar), & 1722 & idivqc(fbdata%nvar), & 1723 & idivqcf(fbdata%nvar), & 1724 & idivlqc(fbdata%nvar), & 1725 & idivlqcf(fbdata%nvar), & 1726 & idiobsi(fbdata%nvar), & 1727 & idiobsj(fbdata%nvar), & 1728 & idiobsk(fbdata%nvar), & 1729 & idcgrid(fbdata%nvar) & 1730 & ) 1731 IF ( fbdata%nadd > 0 ) THEN 1732 ALLOCATE( & 1733 & idpadd(fbdata%nadd,fbdata%nvar) & 1734 & ) 1735 ENDIF 1736 IF ( fbdata%next > 0 ) THEN 1737 ALLOCATE( & 1738 & idpext(fbdata%next) & 1739 & ) 1740 ENDIF 1741 1742 ! Read variables for header information 1743 1744 CALL chkerr( nf90_inq_varid( idfile, 'VARIABLES',idvard ), & 1745 & cpname, __LINE__ ) 1746 CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), & 1747 & cpname, __LINE__ ) 1748 IF ( fbdata%nadd > 0 ) THEN 1749 CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), & 1750 & cpname, __LINE__ ) 1751 CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), & 1752 & cpname, __LINE__ ) 1753 ENDIF 1754 IF ( fbdata%next > 0 ) THEN 1755 CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), & 1756 & cpname, __LINE__ ) 1757 CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), & 1758 & cpname, __LINE__ ) 1759 ENDIF 1760 1761 CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), & 1762 & cpname, __LINE__ ) 1763 CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), & 1764 & cpname, __LINE__ ) 1765 1766 IF ( fbdata%nobs > 0 ) THEN 1767 1768 CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),& 1769 & cpname, __LINE__ ) 1770 CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), & 1771 & cpname, __LINE__ ) 1772 CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), & 1773 & cpname, __LINE__ ) 1774 CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), & 1775 & cpname, __LINE__ ) 1776 CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), & 1777 & cpname, __LINE__ ) 1778 CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), & 1779 & cpname, __LINE__ ) 1780 CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), & 1781 & cpname, __LINE__ ) 1782 CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), & 1783 & cpname, __LINE__ ) 1784 CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), & 1785 & cpname, __LINE__ ) 1786 CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), & 1787 & cpname, __LINE__ ) 1788 CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), & 1789 & cpname, __LINE__ ) 1790 CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), & 1791 & cpname, __LINE__ ) 1792 CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), & 1793 & cpname, __LINE__ ) 1794 CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), & 1795 & cpname, __LINE__ ) 1796 CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), & 1797 & cpname, __LINE__ ) 1798 CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), & 1799 & cpname, __LINE__ ) 1800 CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), & 1801 & cpname, __LINE__ ) 1802 CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), & 1803 & cpname, __LINE__ ) 1804 CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), & 1805 & cpname, __LINE__ ) 1806 CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), & 1807 & cpname, __LINE__ ) 1808 CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), & 1809 & cpname, __LINE__ ) 1810 CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), & 1811 & cpname, __LINE__ ) 1812 CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), & 1813 & cpname, __LINE__ ) 1814 CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), & 1815 & cpname, __LINE__ ) 1816 CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), & 1817 & cpname, __LINE__ ) 1818 CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), & 1819 & cpname, __LINE__ ) 1820 CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), & 1821 & cpname, __LINE__ ) 1822 CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), & 1823 & cpname, __LINE__ ) 1824 CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), & 1825 & cpname, __LINE__ ) 1826 CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), & 1827 & cpname, __LINE__ ) 1828 1829 ! Read netCDF variables for individual variables 1830 1831 DO jv = 1, fbdata%nvar 1832 1833 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' 1834 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), & 1835 & cpname, __LINE__ ) 1836 CALL chkerr( nf90_get_var( idfile, idpob(jv), & 1837 & fbdata%pob(:,:,jv) ), & 1838 & cpname, __LINE__ ) 1839 CALL getvaratt_obfbdata( idfile, idpob(jv), & 1840 & fbdata%coblong(jv), & 1841 & fbdata%cobunit(jv) ) 1842 1843 IF ( fbdata%nadd > 0 ) THEN 1844 DO je = 1, fbdata%nadd 1845 WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& 1846 & TRIM(fbdata%caddname(je)) 1847 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), & 1848 & cpname, __LINE__ ) 1849 CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), & 1850 & fbdata%padd(:,:,je,jv) ), & 1851 & cpname, __LINE__ ) 1852 CALL getvaratt_obfbdata( idfile, idpadd(je,jv), & 1853 & fbdata%caddlong(je,jv), & 1854 & fbdata%caddunit(je,jv) ) 1855 END DO 1856 ENDIF 1857 1858 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC' 1859 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqc(jv) ), & 1860 & cpname, __LINE__ ) 1861 CALL chkerr( nf90_get_var( idfile, idivqc(jv), & 1862 & fbdata%ivqc(:,jv) ), & 1863 & cpname, __LINE__ ) 1864 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' 1865 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), & 1866 & cpname, __LINE__ ) 1867 CALL chkerr( nf90_get_var( idfile, idivqcf(jv), & 1868 & fbdata%ivqcf(:,:,jv) ), & 1869 & cpname, __LINE__ ) 1870 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' 1871 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), & 1872 & cpname, __LINE__ ) 1873 CALL chkerr( nf90_get_var( idfile, idivlqc(jv), & 1874 & fbdata%ivlqc(:,:,jv) ), & 1875 & cpname, __LINE__ ) 1876 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' 1877 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), & 1878 & cpname, __LINE__ ) 1879 CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), & 1880 & fbdata%ivlqcf(:,:,:,jv) ), & 1881 & cpname, __LINE__ ) 1882 IF ( lgrid ) THEN 1883 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' 1884 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), & 1885 & cpname, __LINE__ ) 1886 CALL chkerr( nf90_get_var( idfile, idiobsi(jv), & 1887 & fbdata%iobsi(:,jv) ), & 1888 & cpname, __LINE__ ) 1889 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' 1890 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), & 1891 & cpname, __LINE__ ) 1892 CALL chkerr( nf90_get_var( idfile, idiobsj(jv), & 1893 & fbdata%iobsj(:,jv) ), & 1894 & cpname, __LINE__ ) 1895 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' 1896 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), & 1897 & cpname, __LINE__ ) 1898 CALL chkerr( nf90_get_var( idfile, idiobsk(jv), & 1899 & fbdata%iobsk(:,:,jv) ), & 1900 & cpname, __LINE__ ) 1901 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' 1902 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), & 1903 & cpname, __LINE__ ) 1904 CALL chkerr( nf90_get_var( idfile, idcgrid(jv), & 1905 & fbdata%cgrid(jv) ), & 1906 & cpname, __LINE__ ) 1907 ENDIF 1908 1909 END DO 1910 1911 IF ( fbdata%next > 0 ) THEN 1912 DO je = 1, fbdata%next 1913 WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) 1914 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), & 1915 & cpname, __LINE__ ) 1916 CALL chkerr( nf90_get_var( idfile, idpext(je), & 1917 & fbdata%pext(:,:,je) ), & 1918 & cpname, __LINE__ ) 1919 CALL getvaratt_obfbdata( idfile, idpext(je), & 1920 & fbdata%cextlong(je), & 1921 & fbdata%cextunit(je) ) 1922 END DO 1923 ENDIF 1924 1925 ELSE ! if no observations only get attributes 1926 1927 DO jv = 1, fbdata%nvar 1928 1929 WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_OBS' 1930 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpob(jv) ), & 1931 & cpname, __LINE__ ) 1932 CALL getvaratt_obfbdata( idfile, idpob(jv), & 1933 & fbdata%coblong(jv), & 1934 & fbdata%cobunit(jv) ) 1935 1936 IF ( fbdata%nadd > 0 ) THEN 1937 DO je = 1, fbdata%nadd 1938 WRITE(cdtmp,'(3A)') TRIM(fbdata%cname(jv)),'_',& 1939 & TRIM(fbdata%caddname(je)) 1940 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpadd(je,jv) ), & 1941 & cpname, __LINE__ ) 1942 CALL getvaratt_obfbdata( idfile, idpadd(je,jv), & 1943 & fbdata%caddlong(je,jv), & 1944 & fbdata%caddunit(je,jv) ) 1945 END DO 1946 ENDIF 1947 1948 END DO 1949 1950 IF ( fbdata%next > 0 ) THEN 1951 DO je = 1, fbdata%next 1952 WRITE(cdtmp,'(A)') TRIM(fbdata%cextname(je)) 1953 CALL chkerr( nf90_inq_varid( idfile, cdtmp, idpext(je) ), & 1954 & cpname, __LINE__ ) 1955 CALL getvaratt_obfbdata( idfile, idpext(je), & 1956 & fbdata%cextlong(je), & 1957 & fbdata%cextunit(je) ) 1958 END DO 1959 ENDIF 1960 1961 ENDIF 1962 1963 ! Close the file 1964 1965 CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) 1966 1967 END SUBROUTINE read_obfbdata 1968 1969 SUBROUTINE getvaratt_obfbdata( idfile, idvar, cdlongname, cdunits ) 1970 !!---------------------------------------------------------------------- 1971 !! *** ROUTINE putvaratt_obfbdata *** 1972 !! 1973 !! ** Purpose : Read netcdf attributes for variable 1974 !! 1975 !! ** Method : 1976 !! 1977 !! ** Action : 1978 !! 1979 !!---------------------------------------------------------------------- 1980 !! * Arguments 1981 INTEGER :: idfile ! File netcdf id. 1982 INTEGER :: idvar ! Variable netcdf id. 1983 CHARACTER(len=*) :: cdlongname ! Long name for variable 1984 CHARACTER(len=*) :: cdunits ! Units for variable 1985 !! * Local variables 1986 CHARACTER(LEN=18), PARAMETER :: cpname = 'getvaratt_obfbdata' 1987 1988 CALL chkerr( nf90_get_att( idfile, idvar, 'long_name', & 1989 & cdlongname ), & 1990 & cpname, __LINE__ ) 1991 1992 CALL chkerr( nf90_get_att( idfile, idvar, 'units', & 1993 & cdunits ), & 1994 & cpname, __LINE__ ) 1995 1996 END SUBROUTINE getvaratt_obfbdata 1997 1998 END MODULE obs_fbm
Note: See TracChangeset
for help on using the changeset viewer.
