- Timestamp:
- 2017-05-02T13:21:57+02:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_write.F90
r7960 r7992 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=6) :: clfiletype 97 86 INTEGER :: ilevel 98 87 INTEGER :: jvar … … 102 91 INTEGER :: ja 103 92 INTEGER :: je 93 INTEGER :: iadd 94 INTEGER :: iext 104 95 REAL(wp) :: zpres 105 INTEGER :: nadd106 INTEGER :: next107 96 108 97 IF ( PRESENT( padd ) ) THEN 109 nadd = padd%inum98 iadd = padd%inum 110 99 ELSE 111 nadd = 0100 iadd = 0 112 101 ENDIF 113 102 114 103 IF ( PRESENT( pext ) ) THEN 115 next = pext%inum104 iext = pext%inum 116 105 ELSE 117 next = 0118 ENDIF 119 106 iext = 0 107 ENDIF 108 120 109 CALL init_obfbdata( fbdata ) 121 110 … … 125 114 ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) ) 126 115 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 116 117 SELECT CASE ( TRIM(profdata%cvars(1)) ) 118 CASE('POTM') 119 120 clfiletype='profb' 121 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, & 122 & 1 + iadd, 1 + iext, .TRUE. ) 123 fbdata%cname(1) = profdata%cvars(1) 124 fbdata%cname(2) = profdata%cvars(2) 125 fbdata%coblong(1) = 'Potential temperature' 126 fbdata%coblong(2) = 'Practical salinity' 127 fbdata%cobunit(1) = 'Degrees centigrade' 128 fbdata%cobunit(2) = 'PSU' 129 fbdata%cextname(1) = 'TEMP' 130 fbdata%cextlong(1) = 'Insitu temperature' 131 fbdata%cextunit(1) = 'Degrees centigrade' 132 fbdata%caddlong(1,1) = 'Model interpolated potential temperature' 133 fbdata%caddlong(1,2) = 'Model interpolated practical salinity' 134 fbdata%caddunit(1,1) = 'Degrees centigrade' 135 fbdata%caddunit(1,2) = 'PSU' 136 fbdata%cgrid(:) = 'T' 137 DO je = 1, iext 138 fbdata%cextname(1+je) = pext%cdname(je) 139 fbdata%cextlong(1+je) = pext%cdlong(je,1) 140 fbdata%cextunit(1+je) = pext%cdunit(je,1) 141 END DO 142 DO ja = 1, iadd 143 fbdata%caddname(1+ja) = padd%cdname(ja) 144 DO jvar = 1, 2 145 fbdata%caddlong(1+ja,jvar) = padd%cdlong(ja,jvar) 146 fbdata%caddunit(1+ja,jvar) = padd%cdunit(ja,jvar) 147 END DO 148 END DO 149 150 CASE('UVEL') 151 152 clfiletype='velfb' 153 CALL alloc_obfbdata( fbdata, 2, profdata%nprof, ilevel, 1, 0, .TRUE. ) 154 fbdata%cname(1) = profdata%cvars(1) 155 fbdata%cname(2) = profdata%cvars(2) 156 fbdata%coblong(1) = 'Zonal velocity' 157 fbdata%coblong(2) = 'Meridional velocity' 158 fbdata%cobunit(1) = 'm/s' 159 fbdata%cobunit(2) = 'm/s' 160 DO je = 1, iext 161 fbdata%cextname(je) = pext%cdname(je) 162 fbdata%cextlong(je) = pext%cdlong(je,1) 163 fbdata%cextunit(je) = pext%cdunit(je,1) 164 END DO 165 fbdata%caddlong(1,1) = 'Model interpolated zonal velocity' 166 fbdata%caddlong(1,2) = 'Model interpolated meridional velocity' 167 fbdata%caddunit(1,1) = 'm/s' 168 fbdata%caddunit(1,2) = 'm/s' 169 fbdata%cgrid(1) = 'U' 170 fbdata%cgrid(2) = 'V' 171 DO ja = 1, iadd 172 fbdata%caddname(1+ja) = padd%cdname(ja) 173 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 174 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 175 END DO 176 177 END SELECT 178 144 179 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 180 181 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 159 182 160 183 IF(lwp) THEN 161 184 WRITE(numout,*) 162 WRITE(numout,*)'obs_wri_p 3d:'185 WRITE(numout,*)'obs_wri_prof :' 163 186 WRITE(numout,*)'~~~~~~~~~~~~~' 164 WRITE(numout,*)'Writing profile feedback file : ',TRIM(cfname)165 ENDIF 166 167 ! Transform obs_prof data structure into obfb data structure187 WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname) 188 ENDIF 189 190 ! Transform obs_prof data structure into obfb data structure 168 191 fbdata%cdjuldref = '19500101000000' 169 192 DO jo = 1, profdata%nprof … … 173 196 fbdata%ivqc(jo,:) = profdata%ivqc(jo,:) 174 197 fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:) 175 IF ( profdata%nqc(jo) > 10) THEN176 fbdata%ioqc(jo) = 4198 IF ( profdata%nqc(jo) > 255 ) THEN 199 fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2) 177 200 fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo) 178 fbdata%ioqcf(2,jo) = profdata%nqc(jo) - 10201 fbdata%ioqcf(2,jo) = profdata%nqc(jo) 179 202 ELSE 180 203 fbdata%ioqc(jo) = profdata%nqc(jo) … … 213 236 fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk) 214 237 fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk) 215 IF ( profdata%var(jvar)%nvqc(jk) > 10) THEN216 fbdata%ivlqc(ik,jo,jvar) = 4238 IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN 239 fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2) 217 240 fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk) 218 fbdata%ivlqcf(2,ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) - 10241 fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000 0000 1111 1111') 219 242 ELSE 220 243 fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk) … … 222 245 ENDIF 223 246 fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk) 224 DO ja = 1, nadd247 DO ja = 1, iadd 225 248 fbdata%padd(ik,jo,1+ja,jvar) = & 226 249 & profdata%var(jvar)%vext(jk,padd%ipoint(ja)) 227 250 END DO 228 DO je = 1, next251 DO je = 1, iext 229 252 fbdata%pext(ik,jo,1+je) = & 230 253 & profdata%var(jvar)%vext(jk,pext%ipoint(je)) 231 254 END DO 232 IF ( jvar == 1 ) THEN 255 IF ( ( jvar == 1 ) .AND. & 256 & ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN 233 257 fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1) 234 258 ENDIF … … 237 261 END DO 238 262 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 263 IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN 264 ! Convert insitu temperature to potential temperature using the model 265 ! salinity if no potential temperature 266 DO jo = 1, fbdata%nobs 267 IF ( fbdata%pphi(jo) < 9999.0 ) THEN 268 DO jk = 1, fbdata%nlev 269 IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. & 270 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 271 & ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. & 272 & ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN 273 zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), & 274 & REAL(fbdata%pphi(jo),wp) ) 275 fbdata%pob(jk,jo,1) = potemp( & 276 & REAL(fbdata%padd(jk,jo,1,2), wp), & 277 & REAL(fbdata%pext(jk,jo,1), wp), & 278 & zpres, 0.0_wp ) 279 ENDIF 280 END DO 281 ENDIF 282 END DO 283 ENDIF 284 259 285 ! Write the obfbdata structure 260 CALL write_obfbdata( c fname, fbdata )286 CALL write_obfbdata( clfname, fbdata ) 261 287 262 288 ! Output some basic statistics … … 264 290 265 291 CALL dealloc_obfbdata( fbdata ) 266 267 END SUBROUTINE obs_wri_p 3d268 269 SUBROUTINE obs_wri_s la( cprefix, sladata, padd, pext )292 293 END SUBROUTINE obs_wri_prof 294 295 SUBROUTINE obs_wri_surf( surfdata, padd, pext ) 270 296 !!----------------------------------------------------------------------- 271 297 !! 272 !! *** ROUTINE obs_wri_sla *** 273 !! 274 !! ** Purpose : Write SLA observation diagnostics 275 !! related 298 !! *** ROUTINE obs_wri_surf *** 299 !! 300 !! ** Purpose : Write surface observation files 276 301 !! 277 302 !! ** Method : NetCDF … … 281 306 !! ! 07-03 (K. Mogensen) Original 282 307 !! ! 09-01 (K. Mogensen) New feedback format. 308 !! ! 15-02 (M. Martin) Combined surface writing routine. 283 309 !!----------------------------------------------------------------------- 284 310 … … 287 313 288 314 !! * Arguments 289 CHARACTER(LEN=*), INTENT(IN) :: cprefix ! Prefix for output files 290 TYPE(obs_surf), INTENT(INOUT) :: sladata ! Full set of SLAa 315 TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data 291 316 TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable 292 317 TYPE(obswriinfo), OPTIONAL :: pext ! Extra info … … 294 319 !! * Local declarations 295 320 TYPE(obfbdata) :: fbdata 296 CHARACTER(LEN=40) :: cfname ! netCDF filename 297 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_sla' 321 CHARACTER(LEN=40) :: clfname ! netCDF filename 322 CHARACTER(LEN=6) :: clfiletype 323 CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf' 298 324 INTEGER :: jo 299 325 INTEGER :: ja 300 326 INTEGER :: je 301 INTEGER :: nadd302 INTEGER :: next327 INTEGER :: iadd 328 INTEGER :: iext 303 329 304 330 IF ( PRESENT( padd ) ) THEN 305 nadd = padd%inum331 iadd = padd%inum 306 332 ELSE 307 nadd = 0333 iadd = 0 308 334 ENDIF 309 335 310 336 IF ( PRESENT( pext ) ) THEN 311 next = pext%inum337 iext = pext%inum 312 338 ELSE 313 next = 0339 iext = 0 314 340 ENDIF 315 341 316 342 CALL init_obfbdata( fbdata ) 317 343 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 344 SELECT CASE ( TRIM(surfdata%cvars(1)) ) 345 CASE('SLA') 346 347 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 348 & 2 + iadd, 1 + iext, .TRUE. ) 349 350 clfiletype = 'slafb' 351 fbdata%cname(1) = surfdata%cvars(1) 352 fbdata%coblong(1) = 'Sea level anomaly' 353 fbdata%cobunit(1) = 'Metres' 354 fbdata%cextname(1) = 'MDT' 355 fbdata%cextlong(1) = 'Mean dynamic topography' 356 fbdata%cextunit(1) = 'Metres' 357 DO je = 1, iext 358 fbdata%cextname(je) = pext%cdname(je) 359 fbdata%cextlong(je) = pext%cdlong(je,1) 360 fbdata%cextunit(je) = pext%cdunit(je,1) 361 END DO 362 fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT' 363 fbdata%caddunit(1,1) = 'Metres' 364 fbdata%caddname(2) = 'SSH' 365 fbdata%caddlong(2,1) = 'Model Sea surface height' 366 fbdata%caddunit(2,1) = 'Metres' 367 fbdata%cgrid(1) = 'T' 368 DO ja = 1, iadd 369 fbdata%caddname(2+ja) = padd%cdname(ja) 370 fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1) 371 fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1) 372 END DO 373 374 CASE('SST') 375 376 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 377 & 1 + iadd, iext, .TRUE. ) 378 379 clfiletype = 'sstfb' 380 fbdata%cname(1) = surfdata%cvars(1) 381 fbdata%coblong(1) = 'Sea surface temperature' 382 fbdata%cobunit(1) = 'Degree centigrade' 383 DO je = 1, iext 384 fbdata%cextname(je) = pext%cdname(je) 385 fbdata%cextlong(je) = pext%cdlong(je,1) 386 fbdata%cextunit(je) = pext%cdunit(je,1) 387 END DO 388 fbdata%caddlong(1,1) = 'Model interpolated SST' 389 fbdata%caddunit(1,1) = 'Degree centigrade' 390 fbdata%cgrid(1) = 'T' 391 DO ja = 1, iadd 392 fbdata%caddname(1+ja) = padd%cdname(ja) 393 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 394 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 395 END DO 396 397 CASE('ICECONC') 398 399 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 400 & 1 + iadd, iext, .TRUE. ) 401 402 clfiletype = 'sicfb' 403 fbdata%cname(1) = surfdata%cvars(1) 404 fbdata%coblong(1) = 'Sea ice' 405 fbdata%cobunit(1) = 'Fraction' 406 DO je = 1, iext 407 fbdata%cextname(je) = pext%cdname(je) 408 fbdata%cextlong(je) = pext%cdlong(je,1) 409 fbdata%cextunit(je) = pext%cdunit(je,1) 410 END DO 411 fbdata%caddlong(1,1) = 'Model interpolated ICE' 412 fbdata%caddunit(1,1) = 'Fraction' 413 fbdata%cgrid(1) = 'T' 414 DO ja = 1, iadd 415 fbdata%caddname(1+ja) = padd%cdname(ja) 416 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 417 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 418 END DO 419 420 CASE('SSS') 421 422 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 423 & 1 + iadd, iext, .TRUE. ) 424 425 clfiletype = 'sssfb' 426 fbdata%cname(1) = surfdata%cvars(1) 427 fbdata%coblong(1) = 'Sea surface salinity' 428 fbdata%cobunit(1) = 'psu' 429 DO je = 1, iext 430 fbdata%cextname(je) = pext%cdname(je) 431 fbdata%cextlong(je) = pext%cdlong(je,1) 432 fbdata%cextunit(je) = pext%cdunit(je,1) 433 END DO 434 fbdata%caddlong(1,1) = 'Model interpolated SSS' 435 fbdata%caddunit(1,1) = 'psu' 436 fbdata%cgrid(1) = 'T' 437 DO ja = 1, iadd 438 fbdata%caddname(1+ja) = padd%cdname(ja) 439 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 440 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 441 END DO 442 443 CASE('LOGCHL') 444 445 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 446 & 1 + iadd, iext, .TRUE. ) 447 448 clfiletype = 'logchlfb' 449 fbdata%cname(1) = surfdata%cvars(1) 450 fbdata%coblong(1) = 'logchl concentration' 451 fbdata%cobunit(1) = 'mg/m3' 452 DO je = 1, iext 453 fbdata%cextname(je) = pext%cdname(je) 454 fbdata%cextlong(je) = pext%cdlong(je,1) 455 fbdata%cextunit(je) = pext%cdunit(je,1) 456 END DO 457 fbdata%caddlong(1,1) = 'Model interpolated LOGCHL' 458 fbdata%caddunit(1,1) = 'mg/m3' 459 fbdata%cgrid(1) = 'T' 460 DO ja = 1, iadd 461 fbdata%caddname(1+ja) = padd%cdname(ja) 462 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 463 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 464 END DO 465 466 CASE('SPM') 467 468 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 469 & 1 + iadd, iext, .TRUE. ) 470 471 clfiletype = 'spmfb' 472 fbdata%cname(1) = surfdata%cvars(1) 473 fbdata%coblong(1) = 'spm' 474 fbdata%cobunit(1) = 'g/m3' 475 DO je = 1, iext 476 fbdata%cextname(je) = pext%cdname(je) 477 fbdata%cextlong(je) = pext%cdlong(je,1) 478 fbdata%cextunit(je) = pext%cdunit(je,1) 479 END DO 480 fbdata%caddlong(1,1) = 'Model interpolated spm' 481 fbdata%caddunit(1,1) = 'g/m3' 482 fbdata%cgrid(1) = 'T' 483 DO ja = 1, iadd 484 fbdata%caddname(1+ja) = padd%cdname(ja) 485 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 486 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 487 END DO 488 489 CASE('FCO2') 490 491 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 492 & 1 + iadd, iext, .TRUE. ) 493 494 clfiletype = 'fco2fb' 495 fbdata%cname(1) = surfdata%cvars(1) 496 fbdata%coblong(1) = 'fco2' 497 fbdata%cobunit(1) = 'uatm' 498 DO je = 1, iext 499 fbdata%cextname(je) = pext%cdname(je) 500 fbdata%cextlong(je) = pext%cdlong(je,1) 501 fbdata%cextunit(je) = pext%cdunit(je,1) 502 END DO 503 fbdata%caddlong(1,1) = 'Model interpolated fco2' 504 fbdata%caddunit(1,1) = 'uatm' 505 fbdata%cgrid(1) = 'T' 506 DO ja = 1, iadd 507 fbdata%caddname(1+ja) = padd%cdname(ja) 508 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 509 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 510 END DO 511 512 CASE('PCO2') 513 514 CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & 515 & 1 + iadd, iext, .TRUE. ) 516 517 clfiletype = 'pco2fb' 518 fbdata%cname(1) = surfdata%cvars(1) 519 fbdata%coblong(1) = 'pco2' 520 fbdata%cobunit(1) = 'uatm' 521 DO je = 1, iext 522 fbdata%cextname(je) = pext%cdname(je) 523 fbdata%cextlong(je) = pext%cdlong(je,1) 524 fbdata%cextunit(je) = pext%cdunit(je,1) 525 END DO 526 fbdata%caddlong(1,1) = 'Model interpolated pco2' 527 fbdata%caddunit(1,1) = 'uatm' 528 fbdata%cgrid(1) = 'T' 529 DO ja = 1, iadd 530 fbdata%caddname(1+ja) = padd%cdname(ja) 531 fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1) 532 fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1) 533 END DO 534 535 CASE DEFAULT 536 537 CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) 538 539 END SELECT 540 332 541 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 542 543 WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc 346 544 347 545 IF(lwp) THEN 348 546 WRITE(numout,*) 349 WRITE(numout,*)'obs_wri_s la:'547 WRITE(numout,*)'obs_wri_surf :' 350 548 WRITE(numout,*)'~~~~~~~~~~~~~' 351 WRITE(numout,*)'Writing SLA feedback file : ',TRIM(cfname)352 ENDIF 353 354 ! Transform obs_prof data structure into obfbdata structure549 WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname) 550 ENDIF 551 552 ! Transform surf data structure into obfbdata structure 355 553 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)554 DO jo = 1, surfdata%nsurf 555 fbdata%plam(jo) = surfdata%rlam(jo) 556 fbdata%pphi(jo) = surfdata%rphi(jo) 557 WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo) 360 558 fbdata%ivqc(jo,:) = 0 361 559 fbdata%ivqcf(:,jo,:) = 0 362 IF ( s ladata%nqc(jo) > 10) THEN560 IF ( surfdata%nqc(jo) > 255 ) THEN 363 561 fbdata%ioqc(jo) = 4 364 562 fbdata%ioqcf(1,jo) = 0 365 fbdata%ioqcf(2,jo) = sladata%nqc(jo) - 10563 fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 366 564 ELSE 367 fbdata%ioqc(jo) = s ladata%nqc(jo)565 fbdata%ioqc(jo) = surfdata%nqc(jo) 368 566 fbdata%ioqcf(:,jo) = 0 369 567 ENDIF … … 372 570 fbdata%itqc(jo) = 0 373 571 fbdata%itqcf(:,jo) = 0 374 fbdata%cdwmo(jo) = s ladata%cwmo(jo)375 fbdata%kindex(jo) = s ladata%nsfil(jo)572 fbdata%cdwmo(jo) = surfdata%cwmo(jo) 573 fbdata%kindex(jo) = surfdata%nsfil(jo) 376 574 IF (ln_grid_global) THEN 377 fbdata%iobsi(jo,1) = s ladata%mi(jo)378 fbdata%iobsj(jo,1) = s ladata%mj(jo)575 fbdata%iobsi(jo,1) = surfdata%mi(jo) 576 fbdata%iobsj(jo,1) = surfdata%mj(jo) 379 577 ELSE 380 fbdata%iobsi(jo,1) = mig(s ladata%mi(jo))381 fbdata%iobsj(jo,1) = mjg(s ladata%mj(jo))578 fbdata%iobsi(jo,1) = mig(surfdata%mi(jo)) 579 fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo)) 382 580 ENDIF 383 581 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), &582 & surfdata%nmin(jo), & 583 & surfdata%nhou(jo), & 584 & surfdata%nday(jo), & 585 & surfdata%nmon(jo), & 586 & surfdata%nyea(jo), & 389 587 & fbdata%ptim(jo), & 390 588 & 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)589 fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1) 590 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1) 591 fbdata%pob(1,jo,1) = surfdata%robs(jo,1) 394 592 fbdata%pdep(1,jo) = 0.0 395 593 fbdata%idqc(1,jo) = 0 396 594 fbdata%idqcf(:,1,jo) = 0 397 IF ( s ladata%nqc(jo) > 10) THEN595 IF ( surfdata%nqc(jo) > 255 ) THEN 398 596 fbdata%ivqc(jo,1) = 4 399 597 fbdata%ivlqc(1,jo,1) = 4 400 598 fbdata%ivlqcf(1,1,jo,1) = 0 401 fbdata%ivlqcf(2,1,jo,1) = sladata%nqc(jo) - 10599 fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000 0000 1111 1111') 402 600 ELSE 403 fbdata%ivqc(jo,1) = s ladata%nqc(jo)404 fbdata%ivlqc(1,jo,1) = s ladata%nqc(jo)601 fbdata%ivqc(jo,1) = surfdata%nqc(jo) 602 fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo) 405 603 fbdata%ivlqcf(:,1,jo,1) = 0 406 604 ENDIF 407 605 fbdata%iobsk(1,jo,1) = 0 408 fbdata%pext(1,jo,1) = sladata%rext(jo,2)409 DO ja = 1, nadd606 IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2) 607 DO ja = 1, iadd 410 608 fbdata%padd(1,jo,2+ja,1) = & 411 & s ladata%rext(jo,padd%ipoint(ja))412 END DO 413 DO je = 1, next609 & surfdata%rext(jo,padd%ipoint(ja)) 610 END DO 611 DO je = 1, iext 414 612 fbdata%pext(1,jo,1+je) = & 415 & s ladata%rext(jo,pext%ipoint(je))613 & surfdata%rext(jo,pext%ipoint(je)) 416 614 END DO 417 615 END DO 418 616 419 617 ! Write the obfbdata structure 420 CALL write_obfbdata( c fname, fbdata )618 CALL write_obfbdata( clfname, fbdata ) 421 619 422 620 ! Output some basic statistics … … 425 623 CALL dealloc_obfbdata( fbdata ) 426 624 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 625 END SUBROUTINE obs_wri_surf 931 626 932 627 SUBROUTINE obs_wri_stats( fbdata ) … … 951 646 INTEGER :: jo 952 647 INTEGER :: jk 953 954 ! INTEGER :: nlev 955 ! INTEGER :: nlevmpp 956 ! INTEGER :: nobsmpp 957 INTEGER :: numgoodobs 958 INTEGER :: numgoodobsmpp 648 INTEGER :: inumgoodobs 649 INTEGER :: inumgoodobsmpp 959 650 REAL(wp) :: zsumx 960 651 REAL(wp) :: zsumx2 961 652 REAL(wp) :: zomb 653 962 654 963 655 IF (lwp) THEN 964 656 WRITE(numout,*) '' 965 657 WRITE(numout,*) 'obs_wri_stats :' 966 WRITE(numout,*) '~~~~~~~~~~~~~~~' 658 WRITE(numout,*) '~~~~~~~~~~~~~~~' 967 659 ENDIF 968 660 … … 970 662 zsumx=0.0_wp 971 663 zsumx2=0.0_wp 972 numgoodobs=0664 inumgoodobs=0 973 665 DO jo = 1, fbdata%nobs 974 666 DO jk = 1, fbdata%nlev … … 976 668 & ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. & 977 669 & ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN 978 979 670 671 zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar) 980 672 zsumx=zsumx+zomb 981 673 zsumx2=zsumx2+zomb**2 982 numgoodobs=numgoodobs+1983 674 inumgoodobs=inumgoodobs+1 675 ENDIF 984 676 ENDDO 985 677 ENDDO 986 678 987 CALL obs_mpp_sum_integer( numgoodobs,numgoodobsmpp )679 CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp ) 988 680 CALL mpp_sum(zsumx) 989 681 CALL mpp_sum(zsumx2) 990 682 991 683 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 684 WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp 685 WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp 686 WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp ) 687 WRITE(numout,*) '' 996 688 ENDIF 997 689 998 690 ENDDO 999 691
Note: See TracChangeset
for help on using the changeset viewer.