- Timestamp:
- 2019-07-01T12:44:06+02:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/r6232_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90
r4990 r11202 6 6 7 7 !!---------------------------------------------------------------------- 8 !! obs_wri_p3d : Write profile observation diagnostics in NetCDF format 9 !! obs_wri_sla : Write SLA observation related diagnostics 10 !! obs_wri_sst : Write SST observation related diagnostics 11 !! obs_wri_seaice: Write seaice observation related diagnostics 12 !! obs_wri_vel : Write velocity observation diagnostics in NetCDF format 13 !! obs_wri_stats : Print basic statistics on the data being written out 8 !! obs_wri_prof : Write profile observations in feedback format 9 !! obs_wri_surf : Write surface observations in feedback format 10 !! obs_wri_stats : Print basic statistics on the data being written out 14 11 !!---------------------------------------------------------------------- 15 12 … … 30 27 USE obs_conv ! Conversion between units 31 28 USE obs_const 32 USE obs_sla_types33 USE obs_rot_vel ! Rotation of velocities34 29 USE obs_mpp ! MPP support routines for observation diagnostics 35 30 USE lib_mpp ! MPP routines … … 39 34 !! * Routine accessibility 40 35 PRIVATE 41 PUBLIC obs_wri_p3d, & ! Write profile observation related diagnostics 42 & obs_wri_sla, & ! Write SLA observation related diagnostics 43 & obs_wri_sst, & ! Write SST observation related diagnostics 44 & obs_wri_sss, & ! Write SSS observation related diagnostics 45 & obs_wri_seaice, & ! Write seaice observation related diagnostics 46 & obs_wri_vel, & ! Write velocity observation related diagnostics 36 PUBLIC obs_wri_prof, & ! Write profile observation files 37 & obs_wri_surf, & ! Write surface observation files 47 38 & obswriinfo 48 39 … … 63 54 CONTAINS 64 55 65 SUBROUTINE obs_wri_p 3d( cprefix,profdata, padd, pext )56 SUBROUTINE obs_wri_prof( profdata, padd, pext ) 66 57 !!----------------------------------------------------------------------- 67 58 !! 68 !! *** ROUTINE obs_wri_p3d *** 69 !! 70 !! ** Purpose : Write temperature and salinity (profile) observation 71 !! related diagnostics 59 !! *** ROUTINE obs_wri_prof *** 60 !! 61 !! ** Purpose : Write profile feedback files 72 62 !! 73 63 !! ** Method : NetCDF … … 82 72 !! ! 07-03 (K. Mogensen) General handling of profiles 83 73 !! ! 09-01 (K. Mogensen) New feedback format 74 !! ! 15-02 (M. Martin) Combined routine for writing profiles 84 75 !!----------------------------------------------------------------------- 85 76 86 !! * Modules used87 88 77 !! * Arguments 89 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files90 78 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 91 79 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 92 80 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 93 81 94 82 !! * Local declarations 95 83 TYPE(obfbdata) :: fbdata 96 CHARACTER(LEN=40) :: cfname 84 CHARACTER(LEN=40) :: clfname 85 CHARACTER(LEN=10) :: clfiletype 86 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 87 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 88 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 97 89 INTEGER :: ilevel 98 90 INTEGER :: jvar … … 102 94 INTEGER :: ja 103 95 INTEGER :: je 96 INTEGER :: iadd 97 INTEGER :: iext 104 98 REAL(wp) :: zpres 105 INTEGER :: nadd106 INTEGER :: next107 99 108 100 IF ( PRESENT( padd ) ) THEN 109 nadd = padd%inum101 iadd = padd%inum 110 102 ELSE 111 nadd = 0103 iadd = 0 112 104 ENDIF 113 105 114 106 IF ( PRESENT( pext ) ) THEN 115 next = pext%inum107 iext = pext%inum 116 108 ELSE 117 next = 0118 ENDIF 119 109 iext = 0 110 ENDIF 111 120 112 CALL init_obfbdata( fbdata ) 121 113 122 114 ! Find maximum level 123 115 ilevel = 0 124 DO jvar = 1, 2116 DO jvar = 1, profdata%nvar 125 117 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 126 118 END DO 127 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 128 & 1 + nadd, 1 + next, .TRUE. ) 129 130 fbdata%cname(1) = 'POTM' 131 fbdata%cname(2) = 'PSAL' 132 fbdata%coblong(1) = 'Potential temperature' 133 fbdata%coblong(2) = 'Practical salinity' 134 fbdata%cobunit(1) = 'Degrees centigrade' 135 fbdata%cobunit(2) = 'PSU' 136 fbdata%cextname(1) = 'TEMP' 137 fbdata%cextlong(1) = 'Insitu temperature' 138 fbdata%cextunit(1) = 'Degrees centigrade' 139 DO je = 1, next 140 fbdata%cextname(1+je) = pext%cdname(je) 141 fbdata%cextlong(1+je) = pext%cdlong(je,1) 142 fbdata%cextunit(1+je) = pext%cdunit(je,1) 143 END DO 119 120 SELECT CASE ( TRIM(profdata%cvars(1)) ) 121 CASE('POTM') 122 123 clfiletype='profb' 124 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 125 & 1 + iadd, 1 + iext, .TRUE. ) 126 fbdata%cname(1) = profdata%cvars(1) 127 fbdata%cname(2) = profdata%cvars(2) 128 fbdata%coblong(1) = 'Potential temperature' 129 fbdata%coblong(2) = 'Practical salinity' 130 fbdata%cobunit(1) = 'Degrees centigrade' 131 fbdata%cobunit(2) = 'PSU' 132 fbdata%cextname(1) = 'TEMP' 133 fbdata%cextlong(1) = 'Insitu temperature' 134 fbdata%cextunit(1) = 'Degrees centigrade' 135 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 136 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 137 fbdata%caddunit(1,1) = 'Degrees centigrade' 138 fbdata%caddunit(1,2) = 'PSU' 139 fbdata%cgrid(:) = 'T' 140 DO je = 1, iext 141 fbdata%cextname(1+je) = pext%cdname(je) 142 fbdata%cextlong(1+je) = pext%cdlong(je,1) 143 fbdata%cextunit(1+je) = pext%cdunit(je,1) 144 END DO 145 DO ja = 1, iadd 146 fbdata%caddname(1+ja) = padd%cdname(ja) 147 DO jvar = 1, 2 148 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 149 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 150 END DO 151 END DO 152 153 CASE('UVEL') 154 155 clfiletype='velfb' 156 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) 157 fbdata%cname(1) = profdata%cvars(1) 158 fbdata%cname(2) = profdata%cvars(2) 159 fbdata%coblong(1) = 'Zonal velocity' 160 fbdata%coblong(2) = 'Meridional velocity' 161 fbdata%cobunit(1) = 'm/s' 162 fbdata%cobunit(2) = 'm/s' 163 DO je = 1, iext 164 fbdata%cextname(je) = pext%cdname(je) 165 fbdata%cextlong(je) = pext%cdlong(je,1) 166 fbdata%cextunit(je) = pext%cdunit(je,1) 167 END DO 168 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 169 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 170 fbdata%caddunit(1,1) = 'm/s' 171 fbdata%caddunit(1,2) = 'm/s' 172 fbdata%cgrid(1) = 'U' 173 fbdata%cgrid(2) = 'V' 174 DO ja = 1, iadd 175 fbdata%caddname(1+ja) = padd%cdname(ja) 176 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 177 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 178 END DO 179 180 CASE('PLCHLTOT') 181 182 clfiletype = 'plchltotfb' 183 cllongname = 'log10(chlorophyll concentration)' 184 clunits = 'log10(mg/m3)' 185 clgrid = 'T' 186 187 CASE('PCHLTOT') 188 189 clfiletype = 'pchltotfb' 190 cllongname = 'chlorophyll concentration' 191 clunits = 'mg/m3' 192 clgrid = 'T' 193 194 CASE('PNO3') 195 196 clfiletype = 'pno3fb' 197 cllongname = 'nitrate' 198 clunits = 'mmol/m3' 199 clgrid = 'T' 200 201 CASE('PSI4') 202 203 clfiletype = 'psi4fb' 204 cllongname = 'silicate' 205 clunits = 'mmol/m3' 206 clgrid = 'T' 207 208 CASE('PPO4') 209 210 clfiletype = 'ppo4fb' 211 cllongname = 'phosphate' 212 clunits = 'mmol/m3' 213 clgrid = 'T' 214 215 CASE('PDIC') 216 217 clfiletype = 'pdicfb' 218 cllongname = 'dissolved inorganic carbon' 219 clunits = 'mmol/m3' 220 clgrid = 'T' 221 222 CASE('PALK') 223 224 clfiletype = 'palkfb' 225 cllongname = 'alkalinity' 226 clunits = 'meq/m3' 227 clgrid = 'T' 228 229 CASE('PPH') 230 231 clfiletype = 'pphfb' 232 cllongname = 'pH' 233 clunits = '-' 234 clgrid = 'T' 235 236 CASE('PO2') 237 238 clfiletype = 'po2fb' 239 cllongname = 'dissolved oxygen' 240 clunits = 'mmol/m3' 241 clgrid = 'T' 242 243 END SELECT 244 245 IF ( ( TRIM(profdata%cvars(1)) /= 'POTM' ) .AND. & 246 & ( TRIM(profdata%cvars(1)) /= 'UVEL' ) ) THEN 247 CALL alloc_obfbdata( fbdata, 1, profdata%nprof, ilevel, & 248 & 1 + iadd, iext, .TRUE. ) 249 fbdata%cname(1) = profdata%cvars(1) 250 fbdata%coblong(1) = cllongname 251 fbdata%cobunit(1) = clunits 252 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(cllongname) 253 fbdata%caddunit(1,1) = clunits 254 fbdata%cgrid(:) = clgrid 255 DO je = 1, iext 256 fbdata%cextname(je) = pext%cdname(je) 257 fbdata%cextlong(je) = pext%cdlong(je,1) 258 fbdata%cextunit(je) = pext%cdunit(je,1) 259 END DO 260 DO ja = 1, iadd 261 fbdata%caddname(1+ja) = padd%cdname(ja) 262 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 263 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 264 END DO 265 ENDIF 266 144 267 fbdata%caddname(1) = 'Hx' 145 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 146 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 147 fbdata%caddunit(1,1) = 'Degrees centigrade' 148 fbdata%caddunit(1,2) = 'PSU' 149 fbdata%cgrid(:) = 'T' 150 DO ja = 1, nadd 151 fbdata%caddname(1+ja) = padd%cdname(ja) 152 DO jvar = 1, 2 153 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 154 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 155 END DO 156 END DO 157 158 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 268 269 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 159 270 160 271 IF(lwp) THEN 161 272 WRITE(numout,*) 162 WRITE(numout,*)'obs_wri_p 3d:'273 WRITE(numout,*)'obs_wri_prof :' 163 274 WRITE(numout,*)'~~~~~~~~~~~~~' 164 WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname)165 ENDIF 166 167 ! Transform obs_prof data structure into obfb data structure275 WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 276 ENDIF 277 278 ! Transform obs_prof data structure into obfb data structure 168 279 fbdata%cdjuldref = '19500101000000' 169 280 DO jo = 1, profdata%nprof … … 173 284 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 174 285 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 175 IF ( profdata%nqc(jo) > 10) THEN176 fbdata%ioqc(jo) = 4286 IF ( profdata%nqc(jo) > 255 ) THEN 287 fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2) 177 288 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 178 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10289 fbdata%ioqcf(2,jo) = profdata%nqc(jo) 179 290 ELSE 180 291 fbdata%ioqc(jo) = profdata%nqc(jo) … … 205 316 & krefdate = 19500101 ) 206 317 ! Reform the profiles arrays for output 207 DO jvar = 1, 2318 DO jvar = 1, profdata%nvar 208 319 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 209 320 ik = profdata%var(jvar)%nvlidx(jk) … … 213 324 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 214 325 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 215 IF ( profdata%var(jvar)%nvqc(jk) > 10) THEN216 fbdata%ivlqc(ik,jo,jvar) = 4326 IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN 327 fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) 217 328 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 218 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10329 fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000 0000 1111 1111') 219 330 ELSE 220 331 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) … … 222 333 ENDIF 223 334 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 224 DO ja = 1, nadd335 DO ja = 1, iadd 225 336 fbdata%padd(ik,jo,1+ja,jvar) = & 226 337 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 227 338 END DO 228 DO je = 1, next339 DO je = 1, iext 229 340 fbdata%pext(ik,jo,1+je) = & 230 341 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 231 342 END DO 232 IF ( jvar == 1 ) THEN 343 IF ( ( jvar == 1 ) .AND. & 344 & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 233 345 fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 234 346 ENDIF … … 237 349 END DO 238 350 239 ! Convert insitu temperature to potential temperature using the model 240 ! salinity if no potential temperature 241 DO jo = 1, fbdata%nobs 242 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 243 DO jk = 1, fbdata%nlev 244 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 245 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 246 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 247 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 248 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 249 & REAL(fbdata%pphi(jo),wp) ) 250 fbdata%pob(jk,jo,1) = potemp( & 251 & REAL(fbdata%padd(jk,jo,1,2), wp), & 252 & REAL(fbdata%pext(jk,jo,1), wp), & 253 & zpres, 0.0_wp ) 254 ENDIF 255 END DO 256 ENDIF 257 END DO 258 351 IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 352 ! Convert insitu temperature to potential temperature using the model 353 ! salinity if no potential temperature 354 DO jo = 1, fbdata%nobs 355 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 356 DO jk = 1, fbdata%nlev 357 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 358 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 359 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 360 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 361 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 362 & REAL(fbdata%pphi(jo),wp) ) 363 fbdata%pob(jk,jo,1) = potemp( & 364 & REAL(fbdata%padd(jk,jo,1,2), wp), & 365 & REAL(fbdata%pext(jk,jo,1), wp), & 366 & zpres, 0.0_wp ) 367 ENDIF 368 END DO 369 ENDIF 370 END DO 371 ENDIF 372 259 373 ! Write the obfbdata structure 260 CALL write_obfbdata( c fname, fbdata )374 CALL write_obfbdata( clfname, fbdata ) 261 375 262 376 ! Output some basic statistics … … 264 378 265 379 CALL dealloc_obfbdata( fbdata ) 266 267 END SUBROUTINE obs_wri_p 3d268 269 SUBROUTINE obs_wri_s la( cprefix, sladata, padd, pext )380 381 END SUBROUTINE obs_wri_prof 382 383 SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 270 384 !!----------------------------------------------------------------------- 271 385 !! 272 !! *** ROUTINE obs_wri_sla *** 273 !! 274 !! ** Purpose : Write SLA observation diagnostics 275 !! related 386 !! *** ROUTINE obs_wri_surf *** 387 !! 388 !! ** Purpose : Write surface observation files 276 389 !! 277 390 !! ** Method : NetCDF … … 281 394 !! ! 07-03 (K. Mogensen) Original 282 395 !! ! 09-01 (K. Mogensen) New feedback format. 396 !! ! 15-02 (M. Martin) Combined surface writing routine. 283 397 !!----------------------------------------------------------------------- 284 398 … … 287 401 288 402 !! * Arguments 289 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 290 TYPE(obs_surf), INTENT(INOUT) :: sladata ! Full set of SLAa 403 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 291 404 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 292 405 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info … … 294 407 !! * Local declarations 295 408 TYPE(obfbdata) :: fbdata 296 CHARACTER(LEN=40) :: cfname ! netCDF filename 297 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 409 CHARACTER(LEN=40) :: clfname ! netCDF filename 410 CHARACTER(LEN=10) :: clfiletype 411 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 412 CHARACTER(LEN=ilenlong) :: cllongname ! Long name of variable 413 CHARACTER(LEN=ilenunit) :: clunits ! Units of variable 414 CHARACTER(LEN=ilengrid) :: clgrid ! Grid of variable 298 415 INTEGER :: jo 299 416 INTEGER :: ja 300 417 INTEGER :: je 301 INTEGER :: nadd 302 INTEGER :: next 418 INTEGER :: iadd 419 INTEGER :: iext 420 INTEGER :: indx_std 421 INTEGER :: iadd_std 303 422 304 423 IF ( PRESENT( padd ) ) THEN 305 nadd = padd%inum424 iadd = padd%inum 306 425 ELSE 307 nadd = 0426 iadd = 0 308 427 ENDIF 309 428 310 429 IF ( PRESENT( pext ) ) THEN 311 next = pext%inum430 iext = pext%inum 312 431 ELSE 313 next = 0 314 ENDIF 315 432 iext = 0 433 ENDIF 434 435 iadd_std = 0 436 indx_std = -1 437 IF ( surfdata%nextra > 0 ) THEN 438 DO je = 1, surfdata%nextra 439 IF ( TRIM( surfdata%cext(je) ) == 'STD' ) THEN 440 iadd_std = 1 441 indx_std = je 442 ENDIF 443 END DO 444 ENDIF 445 316 446 CALL init_obfbdata( fbdata ) 317 447 318 CALL alloc_obfbdata( fbdata, 1, sladata%nsurf, 1, & 319 & 2 + nadd, 1 + next, .TRUE. ) 320 321 fbdata%cname(1) = 'SLA' 322 fbdata%coblong(1) = 'Sea level anomaly' 323 fbdata%cobunit(1) = 'Metres' 324 fbdata%cextname(1) = 'MDT' 325 fbdata%cextlong(1) = 'Mean dynamic topography' 326 fbdata%cextunit(1) = 'Metres' 327 DO je = 1, next 328 fbdata%cextname(1+je) = pext%cdname(je) 329 fbdata%cextlong(1+je) = pext%cdlong(je,1) 330 fbdata%cextunit(1+je) = pext%cdunit(je,1) 331 END DO 448 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 449 CASE('SLA') 450 451 ! SLA needs special treatment because of MDT, so is all done here 452 ! Other variables are done more generically 453 454 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 455 & 2 + iadd + iadd_std, 1 + iext, .TRUE. ) 456 457 clfiletype = 'slafb' 458 fbdata%cname(1) = surfdata%cvars(1) 459 fbdata%coblong(1) = 'Sea level anomaly' 460 fbdata%cobunit(1) = 'Metres' 461 fbdata%cextname(1) = 'MDT' 462 fbdata%cextlong(1) = 'Mean dynamic topography' 463 fbdata%cextunit(1) = 'Metres' 464 DO je = 1, iext 465 fbdata%cextname(je) = pext%cdname(je) 466 fbdata%cextlong(je) = pext%cdlong(je,1) 467 fbdata%cextunit(je) = pext%cdunit(je,1) 468 END DO 469 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 470 fbdata%caddunit(1,1) = 'Metres' 471 fbdata%caddname(2) = 'SSH' 472 fbdata%caddlong(2,1) = 'Model Sea surface height' 473 fbdata%caddunit(2,1) = 'Metres' 474 fbdata%cgrid(1) = 'T' 475 DO ja = 1, iadd 476 fbdata%caddname(2+iadd_std+ja) = padd%cdname(ja) 477 fbdata%caddlong(2+iadd_std+ja,1) = padd%cdlong(ja,1) 478 fbdata%caddunit(2+iadd_std+ja,1) = padd%cdunit(ja,1) 479 END DO 480 481 CASE('SST') 482 483 clfiletype = 'sstfb' 484 cllongname = 'Sea surface temperature' 485 clunits = 'Degree centigrade' 486 clgrid = 'T' 487 488 CASE('ICECONC') 489 490 clfiletype = 'sicfb' 491 cllongname = 'Sea ice' 492 clunits = 'Fraction' 493 clgrid = 'T' 494 495 CASE('SSS') 496 497 clfiletype = 'sssfb' 498 cllongname = 'Sea surface salinity' 499 clunits = 'psu' 500 clgrid = 'T' 501 502 CASE('SLCHLTOT','LOGCHL','LogChl','logchl') 503 504 clfiletype = 'slchltotfb' 505 cllongname = 'Surface total log10(chlorophyll)' 506 clunits = 'log10(mg/m3)' 507 clgrid = 'T' 508 509 CASE('SLCHLDIA') 510 511 clfiletype = 'slchldiafb' 512 cllongname = 'Surface diatom log10(chlorophyll)' 513 clunits = 'log10(mg/m3)' 514 clgrid = 'T' 515 516 CASE('SLCHLNON') 517 518 clfiletype = 'slchlnonfb' 519 cllongname = 'Surface non-diatom log10(chlorophyll)' 520 clunits = 'log10(mg/m3)' 521 clgrid = 'T' 522 523 CASE('SLCHLDIN') 524 525 clfiletype = 'slchldinfb' 526 cllongname = 'Surface dinoflagellate log10(chlorophyll)' 527 clunits = 'log10(mg/m3)' 528 clgrid = 'T' 529 530 CASE('SLCHLMIC') 531 532 clfiletype = 'slchlmicfb' 533 cllongname = 'Surface microphytoplankton log10(chlorophyll)' 534 clunits = 'log10(mg/m3)' 535 clgrid = 'T' 536 537 CASE('SLCHLNAN') 538 539 clfiletype = 'slchlnanfb' 540 cllongname = 'Surface nanophytoplankton log10(chlorophyll)' 541 clunits = 'log10(mg/m3)' 542 clgrid = 'T' 543 544 CASE('SLCHLPIC') 545 546 clfiletype = 'slchlpicfb' 547 cllongname = 'Surface picophytoplankton log10(chlorophyll)' 548 clunits = 'log10(mg/m3)' 549 clgrid = 'T' 550 551 CASE('SCHLTOT') 552 553 clfiletype = 'schltotfb' 554 cllongname = 'Surface total chlorophyll' 555 clunits = 'mg/m3' 556 clgrid = 'T' 557 558 CASE('SLPHYTOT') 559 560 clfiletype = 'slphytotfb' 561 cllongname = 'Surface total log10(phytoplankton carbon)' 562 clunits = 'log10(mmolC/m3)' 563 clgrid = 'T' 564 565 CASE('SLPHYDIA') 566 567 clfiletype = 'slphydiafb' 568 cllongname = 'Surface diatom log10(phytoplankton carbon)' 569 clunits = 'log10(mmolC/m3)' 570 clgrid = 'T' 571 572 CASE('SLPHYNON') 573 574 clfiletype = 'slphynonfb' 575 cllongname = 'Surface non-diatom log10(phytoplankton carbon)' 576 clunits = 'log10(mmolC/m3)' 577 clgrid = 'T' 578 579 CASE('SSPM') 580 581 clfiletype = 'sspmfb' 582 cllongname = 'Surface suspended particulate matter' 583 clunits = 'g/m3' 584 clgrid = 'T' 585 586 CASE('SFCO2','FCO2','fCO2','fco2') 587 588 clfiletype = 'sfco2fb' 589 cllongname = 'Surface fugacity of carbon dioxide' 590 clunits = 'uatm' 591 clgrid = 'T' 592 593 CASE('SPCO2') 594 595 clfiletype = 'spco2fb' 596 cllongname = 'Surface partial pressure of carbon dioxide' 597 clunits = 'uatm' 598 clgrid = 'T' 599 600 CASE DEFAULT 601 602 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 603 604 END SELECT 605 606 ! SLA needs special treatment because of MDT, so is done above 607 ! Remaining variables treated more generically 608 609 IF ( TRIM(surfdata%cvars(1)) /= 'SLA' ) THEN 610 611 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 612 & 1 + iadd + iadd_std, iext, .TRUE. ) 613 614 fbdata%cname(1) = surfdata%cvars(1) 615 fbdata%coblong(1) = cllongname 616 fbdata%cobunit(1) = clunits 617 DO je = 1, iext 618 fbdata%cextname(je) = pext%cdname(je) 619 fbdata%cextlong(je) = pext%cdlong(je,1) 620 fbdata%cextunit(je) = pext%cdunit(je,1) 621 END DO 622 IF ( TRIM(surfdata%cvars(1)) == 'ICECONC' ) THEN 623 fbdata%caddlong(1,1) = 'Model interpolated ICE' 624 ELSE 625 fbdata%caddlong(1,1) = 'Model interpolated ' // TRIM(surfdata%cvars(1)) 626 ENDIF 627 fbdata%caddunit(1,1) = clunits 628 fbdata%cgrid(1) = clgrid 629 DO ja = 1, iadd 630 fbdata%caddname(1+iadd_std+ja) = padd%cdname(ja) 631 fbdata%caddlong(1+iadd_std+ja,1) = padd%cdlong(ja,1) 632 fbdata%caddunit(1+iadd_std+ja,1) = padd%cdunit(ja,1) 633 END DO 634 635 ENDIF 636 332 637 fbdata%caddname(1) = 'Hx' 333 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 334 fbdata%caddunit(1,1) = 'Metres' 335 fbdata%caddname(2) = 'SSH' 336 fbdata%caddlong(2,1) = 'Model Sea surface height' 337 fbdata%caddunit(2,1) = 'Metres' 338 fbdata%cgrid(1) = 'T' 339 DO ja = 1, nadd 340 fbdata%caddname(2+ja) = padd%cdname(ja) 341 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 342 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 343 END DO 344 345 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 638 IF ( indx_std /= -1 ) THEN 639 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) iadd_std = iadd_std + 1 640 fbdata%caddname(1+iadd_std) = surfdata%cext(indx_std) 641 fbdata%caddlong(1+iadd_std,1) = 'Obs error standard deviation' 642 fbdata%caddunit(1+iadd_std,1) = fbdata%cobunit(1) 643 ENDIF 644 645 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 346 646 347 647 IF(lwp) THEN 348 648 WRITE(numout,*) 349 WRITE(numout,*)'obs_wri_s la:'649 WRITE(numout,*)'obs_wri_surf :' 350 650 WRITE(numout,*)'~~~~~~~~~~~~~' 351 WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname)352 ENDIF 353 354 ! Transform obs_prof data structure into obfbdata structure651 WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 652 ENDIF 653 654 ! Transform surf data structure into obfbdata structure 355 655 fbdata%cdjuldref = '19500101000000' 356 DO jo = 1, s ladata%nsurf357 fbdata%plam(jo) = s ladata%rlam(jo)358 fbdata%pphi(jo) = s ladata%rphi(jo)359 WRITE(fbdata%cdtyp(jo),'(I4)') s ladata%ntyp(jo)656 DO jo = 1, surfdata%nsurf 657 fbdata%plam(jo) = surfdata%rlam(jo) 658 fbdata%pphi(jo) = surfdata%rphi(jo) 659 WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 360 660 fbdata%ivqc(jo,:) = 0 361 661 fbdata%ivqcf(:,jo,:) = 0 362 IF ( s ladata%nqc(jo) > 10) THEN662 IF ( surfdata%nqc(jo) > 255 ) THEN 363 663 fbdata%ioqc(jo) = 4 364 664 fbdata%ioqcf(1,jo) = 0 365 fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10665 fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 366 666 ELSE 367 fbdata%ioqc(jo) = s ladata%nqc(jo)667 fbdata%ioqc(jo) = surfdata%nqc(jo) 368 668 fbdata%ioqcf(:,jo) = 0 369 669 ENDIF … … 372 672 fbdata%itqc(jo) = 0 373 673 fbdata%itqcf(:,jo) = 0 374 fbdata%cdwmo(jo) = s ladata%cwmo(jo)375 fbdata%kindex(jo) = s ladata%nsfil(jo)674 fbdata%cdwmo(jo) = surfdata%cwmo(jo) 675 fbdata%kindex(jo) = surfdata%nsfil(jo) 376 676 IF (ln_grid_global) THEN 377 fbdata%iobsi(jo,1) = s ladata%mi(jo)378 fbdata%iobsj(jo,1) = s ladata%mj(jo)677 fbdata%iobsi(jo,1) = surfdata%mi(jo) 678 fbdata%iobsj(jo,1) = surfdata%mj(jo) 379 679 ELSE 380 fbdata%iobsi(jo,1) = mig(s ladata%mi(jo))381 fbdata%iobsj(jo,1) = mjg(s ladata%mj(jo))680 fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 681 fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 382 682 ENDIF 383 683 CALL greg2jul( 0, & 384 & s ladata%nmin(jo), &385 & s ladata%nhou(jo), &386 & s ladata%nday(jo), &387 & s ladata%nmon(jo), &388 & s ladata%nyea(jo), &684 & surfdata%nmin(jo), & 685 & surfdata%nhou(jo), & 686 & surfdata%nday(jo), & 687 & surfdata%nmon(jo), & 688 & surfdata%nyea(jo), & 389 689 & fbdata%ptim(jo), & 390 690 & krefdate = 19500101 ) 391 fbdata%padd(1,jo,1,1) = s ladata%rmod(jo,1)392 fbdata%padd(1,jo,2,1) = sladata%rext(jo,1)393 fbdata%pob(1,jo,1) = s ladata%robs(jo,1)691 fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 692 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 693 fbdata%pob(1,jo,1) = surfdata%robs(jo,1) 394 694 fbdata%pdep(1,jo) = 0.0 395 695 fbdata%idqc(1,jo) = 0 396 696 fbdata%idqcf(:,1,jo) = 0 397 IF ( s ladata%nqc(jo) > 10) THEN697 IF ( surfdata%nqc(jo) > 255 ) THEN 398 698 fbdata%ivqc(jo,1) = 4 399 699 fbdata%ivlqc(1,jo,1) = 4 400 700 fbdata%ivlqcf(1,1,jo,1) = 0 401 fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10701 fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 402 702 ELSE 403 fbdata%ivqc(jo,1) = s ladata%nqc(jo)404 fbdata%ivlqc(1,jo,1) = s ladata%nqc(jo)703 fbdata%ivqc(jo,1) = surfdata%nqc(jo) 704 fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) 405 705 fbdata%ivlqcf(:,1,jo,1) = 0 406 706 ENDIF 407 707 fbdata%iobsk(1,jo,1) = 0 408 fbdata%pext(1,jo,1) = sladata%rext(jo,2) 409 DO ja = 1, nadd 410 fbdata%padd(1,jo,2+ja,1) = & 411 & sladata%rext(jo,padd%ipoint(ja)) 412 END DO 413 DO je = 1, next 708 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 709 IF ( indx_std /= -1 ) THEN 710 fbdata%padd(1,jo,1+iadd_std,1) = surfdata%rext(jo,indx_std) 711 ENDIF 712 713 DO ja = 1, iadd 714 fbdata%padd(1,jo,2+iadd_std+ja,1) = & 715 & surfdata%rext(jo,padd%ipoint(ja)) 716 END DO 717 DO je = 1, iext 414 718 fbdata%pext(1,jo,1+je) = & 415 & s ladata%rext(jo,pext%ipoint(je))719 & surfdata%rext(jo,pext%ipoint(je)) 416 720 END DO 417 721 END DO 418 722 419 723 ! Write the obfbdata structure 420 CALL write_obfbdata( c fname, fbdata )724 CALL write_obfbdata( clfname, fbdata ) 421 725 422 726 ! Output some basic statistics … … 425 729 CALL dealloc_obfbdata( fbdata ) 426 730 427 END SUBROUTINE obs_wri_sla 428 429 SUBROUTINE obs_wri_sst( cprefix, sstdata, padd, pext ) 430 !!----------------------------------------------------------------------- 431 !! 432 !! *** ROUTINE obs_wri_sst *** 433 !! 434 !! ** Purpose : Write SST observation diagnostics 435 !! related 436 !! 437 !! ** Method : NetCDF 438 !! 439 !! ** Action : 440 !! 441 !! ! 07-07 (S. Ricci) Original 442 !! ! 09-01 (K. Mogensen) New feedback format. 443 !!----------------------------------------------------------------------- 444 445 !! * Modules used 446 IMPLICIT NONE 447 448 !! * Arguments 449 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 450 TYPE(obs_surf), INTENT(INOUT) :: sstdata ! Full set of SST 451 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 452 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 453 454 !! * Local declarations 455 TYPE(obfbdata) :: fbdata 456 CHARACTER(LEN=40) :: cfname ! netCDF filename 457 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sst' 458 INTEGER :: jo 459 INTEGER :: ja 460 INTEGER :: je 461 INTEGER :: nadd 462 INTEGER :: next 463 464 IF ( PRESENT( padd ) ) THEN 465 nadd = padd%inum 466 ELSE 467 nadd = 0 468 ENDIF 469 470 IF ( PRESENT( pext ) ) THEN 471 next = pext%inum 472 ELSE 473 next = 0 474 ENDIF 475 476 CALL init_obfbdata( fbdata ) 477 478 CALL alloc_obfbdata( fbdata, 1, sstdata%nsurf, 1, & 479 & 1 + nadd, next, .TRUE. ) 480 481 fbdata%cname(1) = 'SST' 482 fbdata%coblong(1) = 'Sea surface temperature' 483 fbdata%cobunit(1) = 'Degree centigrade' 484 DO je = 1, next 485 fbdata%cextname(je) = pext%cdname(je) 486 fbdata%cextlong(je) = pext%cdlong(je,1) 487 fbdata%cextunit(je) = pext%cdunit(je,1) 488 END DO 489 fbdata%caddname(1) = 'Hx' 490 fbdata%caddlong(1,1) = 'Model interpolated SST' 491 fbdata%caddunit(1,1) = 'Degree centigrade' 492 fbdata%cgrid(1) = 'T' 493 DO ja = 1, nadd 494 fbdata%caddname(1+ja) = padd%cdname(ja) 495 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 496 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 497 END DO 498 499 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 500 501 IF(lwp) THEN 502 WRITE(numout,*) 503 WRITE(numout,*)'obs_wri_sst :' 504 WRITE(numout,*)'~~~~~~~~~~~~~' 505 WRITE(numout,*)'Writing SST feedback file : ',TRIM(cfname) 506 ENDIF 507 508 ! Transform obs_prof data structure into obfbdata structure 509 fbdata%cdjuldref = '19500101000000' 510 DO jo = 1, sstdata%nsurf 511 fbdata%plam(jo) = sstdata%rlam(jo) 512 fbdata%pphi(jo) = sstdata%rphi(jo) 513 WRITE(fbdata%cdtyp(jo),'(I4)') sstdata%ntyp(jo) 514 fbdata%ivqc(jo,:) = 0 515 fbdata%ivqcf(:,jo,:) = 0 516 IF ( sstdata%nqc(jo) > 10 ) THEN 517 fbdata%ioqc(jo) = 4 518 fbdata%ioqcf(1,jo) = 0 519 fbdata%ioqcf(2,jo) = sstdata%nqc(jo) - 10 520 ELSE 521 fbdata%ioqc(jo) = MAX(sstdata%nqc(jo),1) 522 fbdata%ioqcf(:,jo) = 0 523 ENDIF 524 fbdata%ipqc(jo) = 0 525 fbdata%ipqcf(:,jo) = 0 526 fbdata%itqc(jo) = 0 527 fbdata%itqcf(:,jo) = 0 528 fbdata%cdwmo(jo) = '' 529 fbdata%kindex(jo) = sstdata%nsfil(jo) 530 IF (ln_grid_global) THEN 531 fbdata%iobsi(jo,1) = sstdata%mi(jo) 532 fbdata%iobsj(jo,1) = sstdata%mj(jo) 533 ELSE 534 fbdata%iobsi(jo,1) = mig(sstdata%mi(jo)) 535 fbdata%iobsj(jo,1) = mjg(sstdata%mj(jo)) 536 ENDIF 537 CALL greg2jul( 0, & 538 & sstdata%nmin(jo), & 539 & sstdata%nhou(jo), & 540 & sstdata%nday(jo), & 541 & sstdata%nmon(jo), & 542 & sstdata%nyea(jo), & 543 & fbdata%ptim(jo), & 544 & krefdate = 19500101 ) 545 fbdata%padd(1,jo,1,1) = sstdata%rmod(jo,1) 546 fbdata%pob(1,jo,1) = sstdata%robs(jo,1) 547 fbdata%pdep(1,jo) = 0.0 548 fbdata%idqc(1,jo) = 0 549 fbdata%idqcf(:,1,jo) = 0 550 IF ( sstdata%nqc(jo) > 10 ) THEN 551 fbdata%ivqc(jo,1) = 4 552 fbdata%ivlqc(1,jo,1) = 4 553 fbdata%ivlqcf(1,1,jo,1) = 0 554 fbdata%ivlqcf(2,1,jo,1) = sstdata%nqc(jo) - 10 555 ELSE 556 fbdata%ivqc(jo,1) = MAX(sstdata%nqc(jo),1) 557 fbdata%ivlqc(1,jo,1) = MAX(sstdata%nqc(jo),1) 558 fbdata%ivlqcf(:,1,jo,1) = 0 559 ENDIF 560 fbdata%iobsk(1,jo,1) = 0 561 DO ja = 1, nadd 562 fbdata%padd(1,jo,1+ja,1) = & 563 & sstdata%rext(jo,padd%ipoint(ja)) 564 END DO 565 DO je = 1, next 566 fbdata%pext(1,jo,je) = & 567 & sstdata%rext(jo,pext%ipoint(je)) 568 END DO 569 570 END DO 571 572 ! Write the obfbdata structure 573 574 CALL write_obfbdata( cfname, fbdata ) 575 576 ! Output some basic statistics 577 CALL obs_wri_stats( fbdata ) 578 579 CALL dealloc_obfbdata( fbdata ) 580 581 END SUBROUTINE obs_wri_sst 582 583 SUBROUTINE obs_wri_sss 584 END SUBROUTINE obs_wri_sss 585 586 SUBROUTINE obs_wri_seaice( cprefix, seaicedata, padd, pext ) 587 !!----------------------------------------------------------------------- 588 !! 589 !! *** ROUTINE obs_wri_seaice *** 590 !! 591 !! ** Purpose : Write sea ice observation diagnostics 592 !! related 593 !! 594 !! ** Method : NetCDF 595 !! 596 !! ** Action : 597 !! 598 !! ! 07-07 (S. Ricci) Original 599 !! ! 09-01 (K. Mogensen) New feedback format. 600 !!----------------------------------------------------------------------- 601 602 !! * Modules used 603 IMPLICIT NONE 604 605 !! * Arguments 606 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 607 TYPE(obs_surf), INTENT(INOUT) :: seaicedata ! Full set of sea ice 608 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 609 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 610 611 !! * Local declarations 612 TYPE(obfbdata) :: fbdata 613 CHARACTER(LEN=40) :: cfname ! netCDF filename 614 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_seaice' 615 INTEGER :: jo 616 INTEGER :: ja 617 INTEGER :: je 618 INTEGER :: nadd 619 INTEGER :: next 620 621 IF ( PRESENT( padd ) ) THEN 622 nadd = padd%inum 623 ELSE 624 nadd = 0 625 ENDIF 626 627 IF ( PRESENT( pext ) ) THEN 628 next = pext%inum 629 ELSE 630 next = 0 631 ENDIF 632 633 CALL init_obfbdata( fbdata ) 634 635 CALL alloc_obfbdata( fbdata, 1, seaicedata%nsurf, 1, 1, 0, .TRUE. ) 636 637 fbdata%cname(1) = 'SEAICE' 638 fbdata%coblong(1) = 'Sea ice' 639 fbdata%cobunit(1) = 'Fraction' 640 DO je = 1, next 641 fbdata%cextname(je) = pext%cdname(je) 642 fbdata%cextlong(je) = pext%cdlong(je,1) 643 fbdata%cextunit(je) = pext%cdunit(je,1) 644 END DO 645 fbdata%caddname(1) = 'Hx' 646 fbdata%caddlong(1,1) = 'Model interpolated ICE' 647 fbdata%caddunit(1,1) = 'Fraction' 648 fbdata%cgrid(1) = 'T' 649 DO ja = 1, nadd 650 fbdata%caddname(1+ja) = padd%cdname(ja) 651 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 652 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 653 END DO 654 655 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 656 657 IF(lwp) THEN 658 WRITE(numout,*) 659 WRITE(numout,*)'obs_wri_seaice :' 660 WRITE(numout,*)'~~~~~~~~~~~~~~~~' 661 WRITE(numout,*)'Writing SEAICE feedback file : ',TRIM(cfname) 662 ENDIF 663 664 ! Transform obs_prof data structure into obfbdata structure 665 fbdata%cdjuldref = '19500101000000' 666 DO jo = 1, seaicedata%nsurf 667 fbdata%plam(jo) = seaicedata%rlam(jo) 668 fbdata%pphi(jo) = seaicedata%rphi(jo) 669 WRITE(fbdata%cdtyp(jo),'(I4)') seaicedata%ntyp(jo) 670 fbdata%ivqc(jo,:) = 0 671 fbdata%ivqcf(:,jo,:) = 0 672 IF ( seaicedata%nqc(jo) > 10 ) THEN 673 fbdata%ioqc(jo) = 4 674 fbdata%ioqcf(1,jo) = 0 675 fbdata%ioqcf(2,jo) = seaicedata%nqc(jo) - 10 676 ELSE 677 fbdata%ioqc(jo) = MAX(seaicedata%nqc(jo),1) 678 fbdata%ioqcf(:,jo) = 0 679 ENDIF 680 fbdata%ipqc(jo) = 0 681 fbdata%ipqcf(:,jo) = 0 682 fbdata%itqc(jo) = 0 683 fbdata%itqcf(:,jo) = 0 684 fbdata%cdwmo(jo) = '' 685 fbdata%kindex(jo) = seaicedata%nsfil(jo) 686 IF (ln_grid_global) THEN 687 fbdata%iobsi(jo,1) = seaicedata%mi(jo) 688 fbdata%iobsj(jo,1) = seaicedata%mj(jo) 689 ELSE 690 fbdata%iobsi(jo,1) = mig(seaicedata%mi(jo)) 691 fbdata%iobsj(jo,1) = mjg(seaicedata%mj(jo)) 692 ENDIF 693 CALL greg2jul( 0, & 694 & seaicedata%nmin(jo), & 695 & seaicedata%nhou(jo), & 696 & seaicedata%nday(jo), & 697 & seaicedata%nmon(jo), & 698 & seaicedata%nyea(jo), & 699 & fbdata%ptim(jo), & 700 & krefdate = 19500101 ) 701 fbdata%padd(1,jo,1,1) = seaicedata%rmod(jo,1) 702 fbdata%pob(1,jo,1) = seaicedata%robs(jo,1) 703 fbdata%pdep(1,jo) = 0.0 704 fbdata%idqc(1,jo) = 0 705 fbdata%idqcf(:,1,jo) = 0 706 IF ( seaicedata%nqc(jo) > 10 ) THEN 707 fbdata%ivlqc(1,jo,1) = 4 708 fbdata%ivlqcf(1,1,jo,1) = 0 709 fbdata%ivlqcf(2,1,jo,1) = seaicedata%nqc(jo) - 10 710 ELSE 711 fbdata%ivlqc(1,jo,1) = MAX(seaicedata%nqc(jo),1) 712 fbdata%ivlqcf(:,1,jo,1) = 0 713 ENDIF 714 fbdata%iobsk(1,jo,1) = 0 715 DO ja = 1, nadd 716 fbdata%padd(1,jo,1+ja,1) = & 717 & seaicedata%rext(jo,padd%ipoint(ja)) 718 END DO 719 DO je = 1, next 720 fbdata%pext(1,jo,je) = & 721 & seaicedata%rext(jo,pext%ipoint(je)) 722 END DO 723 724 END DO 725 726 ! Write the obfbdata structure 727 CALL write_obfbdata( cfname, fbdata ) 728 729 ! Output some basic statistics 730 CALL obs_wri_stats( fbdata ) 731 732 CALL dealloc_obfbdata( fbdata ) 733 734 END SUBROUTINE obs_wri_seaice 735 736 SUBROUTINE obs_wri_vel( cprefix, profdata, k2dint, padd, pext ) 737 !!----------------------------------------------------------------------- 738 !! 739 !! *** ROUTINE obs_wri_vel *** 740 !! 741 !! ** Purpose : Write current (profile) observation 742 !! related diagnostics 743 !! 744 !! ** Method : NetCDF 745 !! 746 !! ** Action : 747 !! 748 !! History : 749 !! ! 09-01 (K. Mogensen) New feedback format routine 750 !!----------------------------------------------------------------------- 751 752 !! * Modules used 753 754 !! * Arguments 755 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 756 TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data 757 INTEGER, INTENT(IN) :: k2dint ! Horizontal interpolation method 758 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 759 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info 760 761 !! * Local declarations 762 TYPE(obfbdata) :: fbdata 763 CHARACTER(LEN=40) :: cfname 764 INTEGER :: ilevel 765 INTEGER :: jvar 766 INTEGER :: jk 767 INTEGER :: ik 768 INTEGER :: jo 769 INTEGER :: ja 770 INTEGER :: je 771 INTEGER :: nadd 772 INTEGER :: next 773 REAL(wp) :: zpres 774 REAL(wp), DIMENSION(:), ALLOCATABLE :: & 775 & zu, & 776 & zv 777 778 IF ( PRESENT( padd ) ) THEN 779 nadd = padd%inum 780 ELSE 781 nadd = 0 782 ENDIF 783 784 IF ( PRESENT( pext ) ) THEN 785 next = pext%inum 786 ELSE 787 next = 0 788 ENDIF 789 790 CALL init_obfbdata( fbdata ) 791 792 ! Find maximum level 793 ilevel = 0 794 DO jvar = 1, 2 795 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 796 END DO 797 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 2, 0, .TRUE. ) 798 799 fbdata%cname(1) = 'UVEL' 800 fbdata%cname(2) = 'VVEL' 801 fbdata%coblong(1) = 'Zonal velocity' 802 fbdata%coblong(2) = 'Meridional velocity' 803 fbdata%cobunit(1) = 'm/s' 804 fbdata%cobunit(2) = 'm/s' 805 DO je = 1, next 806 fbdata%cextname(je) = pext%cdname(je) 807 fbdata%cextlong(je) = pext%cdlong(je,1) 808 fbdata%cextunit(je) = pext%cdunit(je,1) 809 END DO 810 fbdata%caddname(1) = 'Hx' 811 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 812 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 813 fbdata%caddunit(1,1) = 'm/s' 814 fbdata%caddunit(1,2) = 'm/s' 815 fbdata%caddname(2) = 'HxG' 816 fbdata%caddlong(2,1) = 'Model interpolated zonal velocity (model grid)' 817 fbdata%caddlong(2,2) = 'Model interpolated meridional velocity (model grid)' 818 fbdata%caddunit(2,1) = 'm/s' 819 fbdata%caddunit(2,2) = 'm/s' 820 fbdata%cgrid(1) = 'U' 821 fbdata%cgrid(2) = 'V' 822 DO ja = 1, nadd 823 fbdata%caddname(2+ja) = padd%cdname(ja) 824 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 825 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 826 END DO 827 828 WRITE(cfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(cprefix), nproc 829 830 IF(lwp) THEN 831 WRITE(numout,*) 832 WRITE(numout,*)'obs_wri_vel :' 833 WRITE(numout,*)'~~~~~~~~~~~~~' 834 WRITE(numout,*)'Writing velocuty feedback file : ',TRIM(cfname) 835 ENDIF 836 837 ALLOCATE( & 838 & zu(profdata%nvprot(1)), & 839 & zv(profdata%nvprot(2)) & 840 & ) 841 CALL obs_rotvel( profdata, k2dint, zu, zv ) 842 843 ! Transform obs_prof data structure into obfbdata structure 844 fbdata%cdjuldref = '19500101000000' 845 DO jo = 1, profdata%nprof 846 fbdata%plam(jo) = profdata%rlam(jo) 847 fbdata%pphi(jo) = profdata%rphi(jo) 848 WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo) 849 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 850 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 851 IF ( profdata%nqc(jo) > 10 ) THEN 852 fbdata%ioqc(jo) = 4 853 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 854 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10 855 ELSE 856 fbdata%ioqc(jo) = profdata%nqc(jo) 857 fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo) 858 ENDIF 859 fbdata%ipqc(jo) = profdata%ipqc(jo) 860 fbdata%ipqcf(:,jo) = profdata%ipqcf(:,jo) 861 fbdata%itqc(jo) = profdata%itqc(jo) 862 fbdata%itqcf(:,jo) = profdata%itqcf(:,jo) 863 fbdata%cdwmo(jo) = profdata%cwmo(jo) 864 fbdata%kindex(jo) = profdata%npfil(jo) 865 DO jvar = 1, profdata%nvar 866 IF (ln_grid_global) THEN 867 fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar) 868 fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar) 869 ELSE 870 fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar)) 871 fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar)) 872 ENDIF 873 END DO 874 CALL greg2jul( 0, & 875 & profdata%nmin(jo), & 876 & profdata%nhou(jo), & 877 & profdata%nday(jo), & 878 & profdata%nmon(jo), & 879 & profdata%nyea(jo), & 880 & fbdata%ptim(jo), & 881 & krefdate = 19500101 ) 882 ! Reform the profiles arrays for output 883 DO jvar = 1, 2 884 DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar) 885 ik = profdata%var(jvar)%nvlidx(jk) 886 IF ( jvar == 1 ) THEN 887 fbdata%padd(ik,jo,1,jvar) = zu(jk) 888 ELSE 889 fbdata%padd(ik,jo,1,jvar) = zv(jk) 890 ENDIF 891 fbdata%padd(ik,jo,2,jvar) = profdata%var(jvar)%vmod(jk) 892 fbdata%pob(ik,jo,jvar) = profdata%var(jvar)%vobs(jk) 893 fbdata%pdep(ik,jo) = profdata%var(jvar)%vdep(jk) 894 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 895 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 896 IF ( profdata%var(jvar)%nvqc(jk) > 10 ) THEN 897 fbdata%ivlqc(ik,jo,jvar) = 4 898 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 899 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10 900 ELSE 901 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) 902 fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk) 903 ENDIF 904 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 905 DO ja = 1, nadd 906 fbdata%padd(ik,jo,2+ja,jvar) = & 907 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 908 END DO 909 DO je = 1, next 910 fbdata%pext(ik,jo,je) = & 911 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 912 END DO 913 END DO 914 END DO 915 END DO 916 917 ! Write the obfbdata structure 918 CALL write_obfbdata( cfname, fbdata ) 919 920 ! Output some basic statistics 921 CALL obs_wri_stats( fbdata ) 922 923 CALL dealloc_obfbdata( fbdata ) 924 925 DEALLOCATE( & 926 & zu, & 927 & zv & 928 & ) 929 930 END SUBROUTINE obs_wri_vel 731 END SUBROUTINE obs_wri_surf 931 732 932 733 SUBROUTINE obs_wri_stats( fbdata ) … … 951 752 INTEGER :: jo 952 753 INTEGER :: jk 953 954 ! INTEGER :: nlev 955 ! INTEGER :: nlevmpp 956 ! INTEGER :: nobsmpp 957 INTEGER :: numgoodobs 958 INTEGER :: numgoodobsmpp 754 INTEGER :: inumgoodobs 755 INTEGER :: inumgoodobsmpp 959 756 REAL(wp) :: zsumx 960 757 REAL(wp) :: zsumx2 961 758 REAL(wp) :: zomb 759 962 760 963 761 IF (lwp) THEN 964 762 WRITE(numout,*) '' 965 763 WRITE(numout,*) 'obs_wri_stats :' 966 WRITE(numout,*) '~~~~~~~~~~~~~~~' 764 WRITE(numout,*) '~~~~~~~~~~~~~~~' 967 765 ENDIF 968 766 … … 970 768 zsumx=0.0_wp 971 769 zsumx2=0.0_wp 972 numgoodobs=0770 inumgoodobs=0 973 771 DO jo = 1, fbdata%nobs 974 772 DO jk = 1, fbdata%nlev … … 976 774 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 977 775 & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 978 979 776 777 zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 980 778 zsumx=zsumx+zomb 981 779 zsumx2=zsumx2+zomb**2 982 numgoodobs=numgoodobs+1983 780 inumgoodobs=inumgoodobs+1 781 ENDIF 984 782 ENDDO 985 783 ENDDO 986 784 987 CALL obs_mpp_sum_integer( numgoodobs,numgoodobsmpp )785 CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 988 786 CALL mpp_sum(zsumx) 989 787 CALL mpp_sum(zsumx2) 990 788 991 789 IF (lwp) THEN 992 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',numgoodobsmpp993 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/numgoodobsmpp994 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/ numgoodobsmpp )995 790 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp 791 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 792 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 793 WRITE(numout,*) '' 996 794 ENDIF 997 795 998 796 ENDDO 999 797
Note: See TracChangeset
for help on using the changeset viewer.
