New URL for NEMO forge! http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

obs_write.F90 in NEMO/trunk/src/OCE/OBS – NEMO

Context Navigation

source: NEMO/trunk/src/OCE/OBS/obs_write.F90 @ 10425

Last change on this file since 10425 was 10425, checked in by smasson, 5 years ago
trunk: merge back dev_r10164_HPC09_ESIWACE_PREP_MERGE@10424 into the trunk
Property svn:keywords set to `Id`
File size: 22.1 KB

Rev	Line
[2128]	1	MODULE obs_write
	2	!!======================================================================
	3	!! * MODULE obs_write *
	4	!! Observation diagnosticss: Write observation related diagnostics
	5	!!=====================================================================
	6
	7	!!----------------------------------------------------------------------
[6140]	8	!! obs_wri_prof : Write profile observations in feedback format
	9	!! obs_wri_surf : Write surface observations in feedback format
[9023]	10	!! obs_wri_stats : Print basic statistics on the data being written out
[2128]	11	!!----------------------------------------------------------------------
	12
	13	!! * Modules used
	14	USE par_kind, ONLY : & ! Precision variables
	15	& wp
	16	USE in_out_manager ! I/O manager
	17	USE dom_oce ! Ocean space and time domain variables
	18	USE obs_types ! Observation type integer to character translation
	19	USE julian, ONLY : & ! Julian date routines
	20	& greg2jul
	21	USE obs_utils, ONLY : & ! Observation operator utility functions
	22	& chkerr
	23	USE obs_profiles_def ! Type definitions for profiles
	24	USE obs_surf_def ! Type defintions for surface observations
	25	USE obs_fbm ! Observation feedback I/O
	26	USE obs_grid ! Grid tools
	27	USE obs_conv ! Conversion between units
	28	USE obs_const
[4990]	29	USE obs_mpp ! MPP support routines for observation diagnostics
	30	USE lib_mpp ! MPP routines
[2128]	31
	32	IMPLICIT NONE
	33
	34	!! * Routine accessibility
	35	PRIVATE
[6140]	36	PUBLIC obs_wri_prof, & ! Write profile observation files
	37	& obs_wri_surf, & ! Write surface observation files
[2128]	38	& obswriinfo
	39
	40	TYPE obswriinfo
	41	INTEGER :: inum
	42	INTEGER, POINTER, DIMENSION(:) :: ipoint
	43	CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: cdname
	44	CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: cdlong
	45	CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: cdunit
	46	END TYPE obswriinfo
	47
[2287]	48	!!----------------------------------------------------------------------
[9598]	49	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
[2287]	50	!! $Id$
[10068]	51	!! Software governed by the CeCILL license (see ./LICENSE)
[2287]	52	!!----------------------------------------------------------------------
	53
[2128]	54	CONTAINS
	55
[6140]	56	SUBROUTINE obs_wri_prof( profdata, padd, pext )
[2128]	57	!!-----------------------------------------------------------------------
	58	!!
[6140]	59	!! * ROUTINE obs_wri_prof *
[2128]	60	!!
[6140]	61	!! ** Purpose : Write profile feedback files
[2128]	62	!!
	63	!! ** Method : NetCDF
	64	!!
	65	!! ** Action :
	66	!!
	67	!! History :
	68	!! ! 06-04 (A. Vidard) Original
	69	!! ! 06-04 (A. Vidard) Reformatted
	70	!! ! 06-10 (A. Weaver) Cleanup
	71	!! ! 07-01 (K. Mogensen) Use profile data types
	72	!! ! 07-03 (K. Mogensen) General handling of profiles
	73	!! ! 09-01 (K. Mogensen) New feedback format
[6140]	74	!! ! 15-02 (M. Martin) Combined routine for writing profiles
[2128]	75	!!-----------------------------------------------------------------------
	76
	77	!! * Arguments
	78	TYPE(obs_prof), INTENT(INOUT) :: profdata ! Full set of profile data
	79	TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable
	80	TYPE(obswriinfo), OPTIONAL :: pext ! Extra info
[6140]	81
[2128]	82	!! * Local declarations
	83	TYPE(obfbdata) :: fbdata
[6140]	84	CHARACTER(LEN=40) :: clfname
[9023]	85	CHARACTER(LEN=10) :: clfiletype
[2128]	86	INTEGER :: ilevel
	87	INTEGER :: jvar
	88	INTEGER :: jo
	89	INTEGER :: jk
	90	INTEGER :: ik
	91	INTEGER :: ja
	92	INTEGER :: je
[6140]	93	INTEGER :: iadd
	94	INTEGER :: iext
[2128]	95	REAL(wp) :: zpres
	96
	97	IF ( PRESENT( padd ) ) THEN
[6140]	98	iadd = padd%inum
[2128]	99	ELSE
[6140]	100	iadd = 0
[2128]	101	ENDIF
	102
	103	IF ( PRESENT( pext ) ) THEN
[6140]	104	iext = pext%inum
[2128]	105	ELSE
[6140]	106	iext = 0
[2128]	107	ENDIF
[6140]	108
[2128]	109	CALL init_obfbdata( fbdata )
	110
	111	! Find maximum level
	112	ilevel = 0
	113	DO jvar = 1, 2
	114	ilevel = MAX( ilevel, MAXVAL( profdata%var(jvar)%nvlidx(:) ) )
	115	END DO
	116
[6140]	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)
[2128]	141	END DO
[6140]	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
[2128]	149
[6140]	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
	179	fbdata%caddname(1) = 'Hx'
	180
	181	WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc
	182
[2128]	183	IF(lwp) THEN
	184	WRITE(numout,*)
[6140]	185	WRITE(numout,*)'obs_wri_prof :'
[2128]	186	WRITE(numout,*)'~~~~~~~~~~~~~'
[6140]	187	WRITE(numout,*)'Writing '//TRIM(clfiletype)//' feedback file : ',TRIM(clfname)
[2128]	188	ENDIF
	189
[6140]	190	! Transform obs_prof data structure into obfb data structure
[2128]	191	fbdata%cdjuldref = '19500101000000'
	192	DO jo = 1, profdata%nprof
	193	fbdata%plam(jo) = profdata%rlam(jo)
	194	fbdata%pphi(jo) = profdata%rphi(jo)
	195	WRITE(fbdata%cdtyp(jo),'(I4)') profdata%ntyp(jo)
	196	fbdata%ivqc(jo,:) = profdata%ivqc(jo,:)
	197	fbdata%ivqcf(:,jo,:) = profdata%ivqcf(:,jo,:)
[9023]	198	IF ( profdata%nqc(jo) > 255 ) THEN
	199	fbdata%ioqc(jo) = IBSET(profdata%nqc(jo),2)
[2128]	200	fbdata%ioqcf(1,jo) = profdata%nqcf(1,jo)
[9023]	201	fbdata%ioqcf(2,jo) = profdata%nqc(jo)
[2128]	202	ELSE
	203	fbdata%ioqc(jo) = profdata%nqc(jo)
	204	fbdata%ioqcf(:,jo) = profdata%nqcf(:,jo)
	205	ENDIF
	206	fbdata%ipqc(jo) = profdata%ipqc(jo)
	207	fbdata%ipqcf(:,jo) = profdata%ipqcf(:,jo)
	208	fbdata%itqc(jo) = profdata%itqc(jo)
	209	fbdata%itqcf(:,jo) = profdata%itqcf(:,jo)
	210	fbdata%cdwmo(jo) = profdata%cwmo(jo)
	211	fbdata%kindex(jo) = profdata%npfil(jo)
	212	DO jvar = 1, profdata%nvar
	213	IF (ln_grid_global) THEN
	214	fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar)
	215	fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar)
	216	ELSE
	217	fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar))
	218	fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar))
	219	ENDIF
	220	END DO
	221	CALL greg2jul( 0, &
	222	& profdata%nmin(jo), &
	223	& profdata%nhou(jo), &
	224	& profdata%nday(jo), &
	225	& profdata%nmon(jo), &
	226	& profdata%nyea(jo), &
	227	& fbdata%ptim(jo), &
	228	& krefdate = 19500101 )
	229	! Reform the profiles arrays for output
	230	DO jvar = 1, 2
	231	DO jk = profdata%npvsta(jo,jvar), profdata%npvend(jo,jvar)
	232	ik = profdata%var(jvar)%nvlidx(jk)
	233	fbdata%padd(ik,jo,1,jvar) = profdata%var(jvar)%vmod(jk)
	234	fbdata%pob(ik,jo,jvar) = profdata%var(jvar)%vobs(jk)
	235	fbdata%pdep(ik,jo) = profdata%var(jvar)%vdep(jk)
	236	fbdata%idqc(ik,jo) = profdata%var(jvar)%idqc(jk)
	237	fbdata%idqcf(:,ik,jo) = profdata%var(jvar)%idqcf(:,jk)
[9023]	238	IF ( profdata%var(jvar)%nvqc(jk) > 255 ) THEN
	239	fbdata%ivlqc(ik,jo,jvar) = IBSET(profdata%var(jvar)%nvqc(jk),2)
[2128]	240	fbdata%ivlqcf(1,ik,jo,jvar) = profdata%var(jvar)%nvqcf(1,jk)
[9023]	241	!$AGRIF_DO_NOT_TREAT
	242	fbdata%ivlqcf(2,ik,jo,jvar) = IAND(profdata%var(jvar)%nvqc(jk),b'0000000011111111')
	243	!$AGRIF_END_DO_NOT_TREAT
[2128]	244	ELSE
	245	fbdata%ivlqc(ik,jo,jvar) = profdata%var(jvar)%nvqc(jk)
	246	fbdata%ivlqcf(:,ik,jo,jvar) = profdata%var(jvar)%nvqcf(:,jk)
	247	ENDIF
	248	fbdata%iobsk(ik,jo,jvar) = profdata%var(jvar)%mvk(jk)
[6140]	249	DO ja = 1, iadd
[2128]	250	fbdata%padd(ik,jo,1+ja,jvar) = &
	251	& profdata%var(jvar)%vext(jk,padd%ipoint(ja))
	252	END DO
[6140]	253	DO je = 1, iext
[2128]	254	fbdata%pext(ik,jo,1+je) = &
	255	& profdata%var(jvar)%vext(jk,pext%ipoint(je))
	256	END DO
[6140]	257	IF ( ( jvar == 1 ) .AND. &
	258	& ( TRIM(profdata%cvars(1)) == 'POTM' ) ) THEN
[2128]	259	fbdata%pext(ik,jo,1) = profdata%var(jvar)%vext(jk,1)
	260	ENDIF
	261	END DO
	262	END DO
	263	END DO
	264
[6140]	265	IF ( TRIM(profdata%cvars(1)) == 'POTM' ) THEN
	266	! Convert insitu temperature to potential temperature using the model
	267	! salinity if no potential temperature
	268	DO jo = 1, fbdata%nobs
	269	IF ( fbdata%pphi(jo) < 9999.0 ) THEN
	270	DO jk = 1, fbdata%nlev
	271	IF ( ( fbdata%pob(jk,jo,1) >= 9999.0 ) .AND. &
	272	& ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
	273	& ( fbdata%padd(jk,jo,1,2) < 9999.0 ) .AND. &
	274	& ( fbdata%pext(jk,jo,1) < 9999.0 ) ) THEN
	275	zpres = dep_to_p( REAL(fbdata%pdep(jk,jo),wp), &
	276	& REAL(fbdata%pphi(jo),wp) )
	277	fbdata%pob(jk,jo,1) = potemp( &
	278	& REAL(fbdata%padd(jk,jo,1,2), wp), &
	279	& REAL(fbdata%pext(jk,jo,1), wp), &
	280	& zpres, 0.0_wp )
	281	ENDIF
	282	END DO
	283	ENDIF
	284	END DO
	285	ENDIF
	286
[2128]	287	! Write the obfbdata structure
[6140]	288	CALL write_obfbdata( clfname, fbdata )
[4990]	289
	290	! Output some basic statistics
	291	CALL obs_wri_stats( fbdata )
	292
[2128]	293	CALL dealloc_obfbdata( fbdata )
	294
[6140]	295	END SUBROUTINE obs_wri_prof
	296
	297	SUBROUTINE obs_wri_surf( surfdata, padd, pext )
[2128]	298	!!-----------------------------------------------------------------------
	299	!!
[6140]	300	!! * ROUTINE obs_wri_surf *
[2128]	301	!!
[6140]	302	!! ** Purpose : Write surface observation files
[2128]	303	!!
	304	!! ** Method : NetCDF
	305	!!
	306	!! ** Action :
	307	!!
	308	!! ! 07-03 (K. Mogensen) Original
	309	!! ! 09-01 (K. Mogensen) New feedback format.
[6140]	310	!! ! 15-02 (M. Martin) Combined surface writing routine.
[2128]	311	!!-----------------------------------------------------------------------
	312
	313	!! * Modules used
	314	IMPLICIT NONE
	315
	316	!! * Arguments
[6140]	317	TYPE(obs_surf), INTENT(INOUT) :: surfdata ! Full set of surface data
[2128]	318	TYPE(obswriinfo), OPTIONAL :: padd ! Additional info for each variable
	319	TYPE(obswriinfo), OPTIONAL :: pext ! Extra info
	320
	321	!! * Local declarations
	322	TYPE(obfbdata) :: fbdata
[6140]	323	CHARACTER(LEN=40) :: clfname ! netCDF filename
[9023]	324	CHARACTER(LEN=10) :: clfiletype
[6140]	325	CHARACTER(LEN=12), PARAMETER :: cpname = 'obs_wri_surf'
[2128]	326	INTEGER :: jo
	327	INTEGER :: ja
	328	INTEGER :: je
[6140]	329	INTEGER :: iadd
	330	INTEGER :: iext
[2128]	331
	332	IF ( PRESENT( padd ) ) THEN
[6140]	333	iadd = padd%inum
[2128]	334	ELSE
[6140]	335	iadd = 0
[2128]	336	ENDIF
	337
	338	IF ( PRESENT( pext ) ) THEN
[6140]	339	iext = pext%inum
[2128]	340	ELSE
[6140]	341	iext = 0
[2128]	342	ENDIF
	343
	344	CALL init_obfbdata( fbdata )
	345
[6140]	346	SELECT CASE ( TRIM(surfdata%cvars(1)) )
	347	CASE('SLA')
[2128]	348
[6140]	349	CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
	350	& 2 + iadd, 1 + iext, .TRUE. )
[2128]	351
[6140]	352	clfiletype = 'slafb'
	353	fbdata%cname(1) = surfdata%cvars(1)
	354	fbdata%coblong(1) = 'Sea level anomaly'
	355	fbdata%cobunit(1) = 'Metres'
	356	fbdata%cextname(1) = 'MDT'
	357	fbdata%cextlong(1) = 'Mean dynamic topography'
	358	fbdata%cextunit(1) = 'Metres'
	359	DO je = 1, iext
	360	fbdata%cextname(je) = pext%cdname(je)
	361	fbdata%cextlong(je) = pext%cdlong(je,1)
	362	fbdata%cextunit(je) = pext%cdunit(je,1)
[2128]	363	END DO
[6140]	364	fbdata%caddlong(1,1) = 'Model interpolated SSH - MDT'
	365	fbdata%caddunit(1,1) = 'Metres'
	366	fbdata%caddname(2) = 'SSH'
	367	fbdata%caddlong(2,1) = 'Model Sea surface height'
	368	fbdata%caddunit(2,1) = 'Metres'
	369	fbdata%cgrid(1) = 'T'
	370	DO ja = 1, iadd
	371	fbdata%caddname(2+ja) = padd%cdname(ja)
	372	fbdata%caddlong(2+ja,1) = padd%cdlong(ja,1)
	373	fbdata%caddunit(2+ja,1) = padd%cdunit(ja,1)
[2128]	374	END DO
	375
[6140]	376	CASE('SST')
[2128]	377
[6140]	378	CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
	379	& 1 + iadd, iext, .TRUE. )
[4990]	380
[6140]	381	clfiletype = 'sstfb'
	382	fbdata%cname(1) = surfdata%cvars(1)
	383	fbdata%coblong(1) = 'Sea surface temperature'
	384	fbdata%cobunit(1) = 'Degree centigrade'
	385	DO je = 1, iext
	386	fbdata%cextname(je) = pext%cdname(je)
	387	fbdata%cextlong(je) = pext%cdlong(je,1)
	388	fbdata%cextunit(je) = pext%cdunit(je,1)
	389	END DO
	390	fbdata%caddlong(1,1) = 'Model interpolated SST'
	391	fbdata%caddunit(1,1) = 'Degree centigrade'
	392	fbdata%cgrid(1) = 'T'
	393	DO ja = 1, iadd
	394	fbdata%caddname(1+ja) = padd%cdname(ja)
	395	fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
	396	fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
	397	END DO
[2128]	398
[9023]	399	CASE('ICECONC')
[2128]	400
[6140]	401	CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
	402	& 1 + iadd, iext, .TRUE. )
[2128]	403
[6140]	404	clfiletype = 'sicfb'
	405	fbdata%cname(1) = surfdata%cvars(1)
	406	fbdata%coblong(1) = 'Sea ice'
	407	fbdata%cobunit(1) = 'Fraction'
	408	DO je = 1, iext
	409	fbdata%cextname(je) = pext%cdname(je)
	410	fbdata%cextlong(je) = pext%cdlong(je,1)
	411	fbdata%cextunit(je) = pext%cdunit(je,1)
	412	END DO
	413	fbdata%caddlong(1,1) = 'Model interpolated ICE'
	414	fbdata%caddunit(1,1) = 'Fraction'
	415	fbdata%cgrid(1) = 'T'
	416	DO ja = 1, iadd
	417	fbdata%caddname(1+ja) = padd%cdname(ja)
	418	fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
	419	fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
	420	END DO
[2128]	421
[9023]	422	CASE('SSS')
	423
	424	CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, &
	425	& 1 + iadd, iext, .TRUE. )
	426
	427	clfiletype = 'sssfb'
	428	fbdata%cname(1) = surfdata%cvars(1)
	429	fbdata%coblong(1) = 'Sea surface salinity'
	430	fbdata%cobunit(1) = 'psu'
	431	DO je = 1, iext
	432	fbdata%cextname(je) = pext%cdname(je)
	433	fbdata%cextlong(je) = pext%cdlong(je,1)
	434	fbdata%cextunit(je) = pext%cdunit(je,1)
	435	END DO
	436	fbdata%caddlong(1,1) = 'Model interpolated SSS'
	437	fbdata%caddunit(1,1) = 'psu'
	438	fbdata%cgrid(1) = 'T'
	439	DO ja = 1, iadd
	440	fbdata%caddname(1+ja) = padd%cdname(ja)
	441	fbdata%caddlong(1+ja,1) = padd%cdlong(ja,1)
	442	fbdata%caddunit(1+ja,1) = padd%cdunit(ja,1)
	443	END DO
	444
	445	CASE DEFAULT
	446
	447	CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' )
	448
[6140]	449	END SELECT
[2128]	450
	451	fbdata%caddname(1) = 'Hx'
	452
[6140]	453	WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc
[2128]	454
	455	IF(lwp) THEN
	456	WRITE(numout,*)
[6140]	457	WRITE(numout,*)'obs_wri_surf :'
[2128]	458	WRITE(numout,*)'~~~~~~~~~~~~~'
[6140]	459	WRITE(numout,*)'Writing '//TRIM(surfdata%cvars(1))//' feedback file : ',TRIM(clfname)
[2128]	460	ENDIF
	461
[6140]	462	! Transform surf data structure into obfbdata structure
[2128]	463	fbdata%cdjuldref = '19500101000000'
[6140]	464	DO jo = 1, surfdata%nsurf
	465	fbdata%plam(jo) = surfdata%rlam(jo)
	466	fbdata%pphi(jo) = surfdata%rphi(jo)
	467	WRITE(fbdata%cdtyp(jo),'(I4)') surfdata%ntyp(jo)
[2128]	468	fbdata%ivqc(jo,:) = 0
	469	fbdata%ivqcf(:,jo,:) = 0
[9023]	470	IF ( surfdata%nqc(jo) > 255 ) THEN
[2128]	471	fbdata%ioqc(jo) = 4
	472	fbdata%ioqcf(1,jo) = 0
[9023]	473	!$AGRIF_DO_NOT_TREAT
	474	fbdata%ioqcf(2,jo) = IAND(surfdata%nqc(jo),b'0000000011111111')
	475	!$AGRIF_END_DO_NOT_TREAT
[2128]	476	ELSE
[6140]	477	fbdata%ioqc(jo) = surfdata%nqc(jo)
[2128]	478	fbdata%ioqcf(:,jo) = 0
	479	ENDIF
	480	fbdata%ipqc(jo) = 0
	481	fbdata%ipqcf(:,jo) = 0
	482	fbdata%itqc(jo) = 0
	483	fbdata%itqcf(:,jo) = 0
[6140]	484	fbdata%cdwmo(jo) = surfdata%cwmo(jo)
	485	fbdata%kindex(jo) = surfdata%nsfil(jo)
[2128]	486	IF (ln_grid_global) THEN
[6140]	487	fbdata%iobsi(jo,1) = surfdata%mi(jo)
	488	fbdata%iobsj(jo,1) = surfdata%mj(jo)
[2128]	489	ELSE
[6140]	490	fbdata%iobsi(jo,1) = mig(surfdata%mi(jo))
	491	fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo))
[2128]	492	ENDIF
	493	CALL greg2jul( 0, &
[6140]	494	& surfdata%nmin(jo), &
	495	& surfdata%nhou(jo), &
	496	& surfdata%nday(jo), &
	497	& surfdata%nmon(jo), &
	498	& surfdata%nyea(jo), &
[2128]	499	& fbdata%ptim(jo), &
	500	& krefdate = 19500101 )
[6140]	501	fbdata%padd(1,jo,1,1) = surfdata%rmod(jo,1)
	502	IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%padd(1,jo,2,1) = surfdata%rext(jo,1)
	503	fbdata%pob(1,jo,1) = surfdata%robs(jo,1)
[2128]	504	fbdata%pdep(1,jo) = 0.0
	505	fbdata%idqc(1,jo) = 0
	506	fbdata%idqcf(:,1,jo) = 0
[9023]	507	IF ( surfdata%nqc(jo) > 255 ) THEN
[2128]	508	fbdata%ivqc(jo,1) = 4
	509	fbdata%ivlqc(1,jo,1) = 4
	510	fbdata%ivlqcf(1,1,jo,1) = 0
[9023]	511	!$AGRIF_DO_NOT_TREAT
	512	fbdata%ivlqcf(2,1,jo,1) = IAND(surfdata%nqc(jo),b'0000000011111111')
	513	!$AGRIF_END_DO_NOT_TREAT
[2128]	514	ELSE
[6140]	515	fbdata%ivqc(jo,1) = surfdata%nqc(jo)
	516	fbdata%ivlqc(1,jo,1) = surfdata%nqc(jo)
[2128]	517	fbdata%ivlqcf(:,1,jo,1) = 0
	518	ENDIF
	519	fbdata%iobsk(1,jo,1) = 0
[6140]	520	IF ( TRIM(surfdata%cvars(1)) == 'SLA' ) fbdata%pext(1,jo,1) = surfdata%rext(jo,2)
	521	DO ja = 1, iadd
	522	fbdata%padd(1,jo,2+ja,1) = &
	523	& surfdata%rext(jo,padd%ipoint(ja))
[2128]	524	END DO
[6140]	525	DO je = 1, iext
	526	fbdata%pext(1,jo,1+je) = &
	527	& surfdata%rext(jo,pext%ipoint(je))
[2128]	528	END DO
	529	END DO
	530
	531	! Write the obfbdata structure
[6140]	532	CALL write_obfbdata( clfname, fbdata )
[2128]	533
[4990]	534	! Output some basic statistics
	535	CALL obs_wri_stats( fbdata )
	536
[2128]	537	CALL dealloc_obfbdata( fbdata )
	538
[6140]	539	END SUBROUTINE obs_wri_surf
[2128]	540
[4990]	541	SUBROUTINE obs_wri_stats( fbdata )
	542	!!-----------------------------------------------------------------------
	543	!!
	544	!! * ROUTINE obs_wri_stats *
	545	!!
	546	!! ** Purpose : Output some basic statistics of the data being written out
	547	!!
	548	!! ** Method :
	549	!!
	550	!! ** Action :
	551	!!
	552	!! ! 2014-08 (D. Lea) Initial version
	553	!!-----------------------------------------------------------------------
	554
	555	!! * Arguments
	556	TYPE(obfbdata) :: fbdata
	557
	558	!! * Local declarations
	559	INTEGER :: jvar
	560	INTEGER :: jo
	561	INTEGER :: jk
[6140]	562	INTEGER :: inumgoodobs
	563	INTEGER :: inumgoodobsmpp
[4990]	564	REAL(wp) :: zsumx
	565	REAL(wp) :: zsumx2
	566	REAL(wp) :: zomb
[6140]	567
[4990]	568
	569	IF (lwp) THEN
	570	WRITE(numout,*) ''
	571	WRITE(numout,*) 'obs_wri_stats :'
[6140]	572	WRITE(numout,*) '~~~~~~~~~~~~~~~'
[4990]	573	ENDIF
	574
	575	DO jvar = 1, fbdata%nvar
	576	zsumx=0.0_wp
	577	zsumx2=0.0_wp
[6140]	578	inumgoodobs=0
[4990]	579	DO jo = 1, fbdata%nobs
	580	DO jk = 1, fbdata%nlev
	581	IF ( ( fbdata%pob(jk,jo,jvar) < 9999.0 ) .AND. &
	582	& ( fbdata%pdep(jk,jo) < 9999.0 ) .AND. &
	583	& ( fbdata%padd(jk,jo,1,jvar) < 9999.0 ) ) THEN
[6140]	584
	585	zomb=fbdata%pob(jk, jo, jvar)-fbdata%padd(jk, jo, 1, jvar)
[4990]	586	zsumx=zsumx+zomb
	587	zsumx2=zsumx2+zomb**2
[6140]	588	inumgoodobs=inumgoodobs+1
	589	ENDIF
[4990]	590	ENDDO
	591	ENDDO
	592
[6140]	593	CALL obs_mpp_sum_integer( inumgoodobs, inumgoodobsmpp )
[10425]	594	CALL mpp_sum('obs_write', zsumx)
	595	CALL mpp_sum('obs_write', zsumx2)
[4990]	596
	597	IF (lwp) THEN
[6140]	598	WRITE(numout,*) 'Type: ',fbdata%cname(jvar),' Total number of good observations: ',inumgoodobsmpp
	599	WRITE(numout,*) 'Overall mean obs minus model of the good observations: ',zsumx/inumgoodobsmpp
	600	WRITE(numout,*) 'Overall RMS obs minus model of the good observations: ',sqrt( zsumx2/inumgoodobsmpp )
	601	WRITE(numout,*) ''
[4990]	602	ENDIF
[6140]	603
[4990]	604	ENDDO
	605
	606	END SUBROUTINE obs_wri_stats
	607
[2128]	608	END MODULE obs_write

Note: See TracBrowser for help on using the repository browser.

Download in other formats: