Context Navigation

obs_profiles_def.F90 @ 15497

Last change on this file since 15497 was 15487, checked in by dford, 3 years ago
Remove some comments and add some spaces.
File size: 40.3 KB

Line
1	MODULE obs_profiles_def
2	!!=====================================================================
3	!! * MODULE obs_profiles_def *
4	!! Observation diagnostics: Storage handling for T,S profiles
5	!! arrays and additional flags etc.
6	!! This module only defines the data type and
7	!! operations on the data type. There is no
8	!! actual data in the module.
9	!!=====================================================================
10
11	!!----------------------------------------------------------------------
12	!! obs_prof : F90 type containing the profile information
13	!! obs_prof_var : F90 type containing the variable definition
14	!! obs_prof_valid : F90 type containing the valid obs. definition
15	!! obs_prof_alloc : Allocates profile arrays
16	!! obs_prof_dealloc : Deallocates profile arrays
17	!! obs_prof_compress : Extract sub-information from a obs_prof type
18	!! to a new obs_prof type
19	!! obs_prof_decompress : Reinsert sub-information from a obs_prof type
20	!! into the original obs_prof type
21	!! obs_prof_staend : Set npvsta and npvend of a variable within an
22	!! obs_prof_var type
23	!!----------------------------------------------------------------------
24	!! * Modules used
25	USE par_kind, ONLY : & ! Precision variables
26	& wp
27	USE in_out_manager ! I/O manager
28	USE obs_mpp, ONLY : & ! MPP tools
29	obs_mpp_sum_integers
30	USE obs_fbm ! Obs feedback format
31	USE lib_mpp, ONLY : &
32	& ctl_warn, ctl_stop
33
34	IMPLICIT NONE
35
36	!! * Routine/type accessibility
37	PRIVATE
38
39	PUBLIC &
40	& obs_prof, &
41	& obs_prof_var, &
42	& obs_prof_valid, &
43	& obs_prof_alloc, &
44	& obs_prof_alloc_var, &
45	& obs_prof_alloc_ext, &
46	& obs_prof_dealloc, &
47	& obs_prof_compress, &
48	& obs_prof_decompress,&
49	& obs_prof_staend, &
50	& obs_prof_staend_ext
51
52	!! * Type definition for valid observations
53
54	TYPE obs_prof_valid
55
56	LOGICAL, POINTER, DIMENSION(:) :: luse
57
58	END TYPE obs_prof_valid
59
60	!! * Type definition for each variable
61
62	TYPE obs_prof_var
63
64	! Arrays with size equal to the number of observations
65
66	INTEGER, POINTER, DIMENSION(:) :: &
67	& mvk, & !: k-th grid coord. for interpolating to profile data
68	& nvpidx,& !: Profile number
69	& nvlidx,& !: Level number in profile
70	& nvqc, & !: Variable QC flags
71	& idqc !: Depth QC flag
72
73	REAL(KIND=wp), POINTER, DIMENSION(:) :: &
74	& vdep, & !: Depth coordinate of profile data
75	& vobs, & !: Profile data
76	& vmod !: Model counterpart of the profile data vector
77
78	REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
79	& vadd !: Additional variables
80
81	INTEGER, POINTER, DIMENSION(:) :: &
82	& nvind !: Source indices of temp. data in compressed data
83
84	! Arrays with size equal to idefnqcf times the number of observations
85	INTEGER, POINTER, DIMENSION(:,:) :: &
86	& idqcf, & !: Depth QC flags
87	& nvqcf !: Variable QC flags
88
89	END TYPE obs_prof_var
90
91	!! * Type definition for extra variables
92
93	TYPE obs_prof_ext
94
95	! Arrays with size equal to the number of observations
96
97	INTEGER, POINTER, DIMENSION(:) :: &
98	& nepidx,& !: Profile number
99	& nelidx !: Level number in profile
100
101	REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
102	& eobs !: Profile data
103
104	INTEGER, POINTER, DIMENSION(:) :: &
105	& neind !: Source indices of temp. data in compressed data
106
107	END TYPE obs_prof_ext
108
109	!! * Type definition for profile observation type
110
111	TYPE obs_prof
112
113	! Bookkeeping
114
115	INTEGER :: nvar !: Number of variables
116	INTEGER :: next !: Number of extra variables
117	INTEGER :: nadd !: Number of additional variables
118	INTEGER :: nprof !: Total number of profiles within window.
119	INTEGER :: nstp !: Number of time steps
120	INTEGER :: npi !: Number of 3D grid points
121	INTEGER :: npj
122	INTEGER :: npk
123	INTEGER :: nprofup !: Observation counter used in obs_oper
124
125	! Bookkeeping arrays with sizes equal to number of variables
126
127	CHARACTER(len=ilenname), POINTER, DIMENSION(:) :: &
128	& cvars, & !: Variable names
129	& cextvars, & !: Extra variable names
130	& caddvars !: Additional variable names
131
132	CHARACTER(len=ilenlong), POINTER, DIMENSION(:) :: &
133	& clong, & !: Variable long names
134	& cextlong !: Extra variable long names
135
136	CHARACTER(len=ilenlong), POINTER, DIMENSION(:,:) :: &
137	& caddlong !: Additional variable long names
138
139	CHARACTER(len=ilenunit), POINTER, DIMENSION(:) :: &
140	& cunit, & !: Variable units
141	& cextunit !: Extra variable units
142
143	CHARACTER(len=ilenunit), POINTER, DIMENSION(:,:) :: &
144	& caddunit !: Additional variable units
145
146	CHARACTER(len=ilengrid), POINTER, DIMENSION(:) :: &
147	& cgrid !: Variable grids
148
149	INTEGER, POINTER, DIMENSION(:) :: &
150	& nvprot, & !: Local total number of profile data
151	& nvprotmpp !: Global total number of profile data
152
153	! Arrays with size equal to the number of profiles
154
155	INTEGER, POINTER, DIMENSION(:) :: &
156	& npidx,& !: Profile number
157	& npfil,& !: Profile number in file
158	& nyea, & !: Year of profile
159	& nmon, & !: Month of profile
160	& nday, & !: Day of profile
161	& nhou, & !: Hour of profile
162	& nmin, & !: Minute of profile
163	& mstp, & !: Time step nearest to profile
164	& nqc, & !: Profile QC
165	& ntyp, & !: Type of profile product (WMO table 1770)
166	& ipqc, & !: Position QC
167	& itqc !: Time QC
168
169	REAL(KIND=wp), POINTER, DIMENSION(:) :: &
170	& rlam, & !: Longitude coordinate of profile data
171	& rphi !: Latitude coordinate of profile data
172
173	CHARACTER(LEN=ilenwmo), POINTER, DIMENSION(:) :: &
174	& cwmo !: Profile WMO indentifier
175
176	! Arrays with size equal to the number of profiles times
177	! number of variables
178
179	INTEGER, POINTER, DIMENSION(:,:) :: &
180	& npvsta, & !: Start of each variable profile in full arrays
181	& npvend, & !: End of each variable profile in full arrays
182	& mi, & !: i-th grid coord. for interpolating to profile data
183	& mj, & !: j-th grid coord. for interpolating to profile data
184	& ivqc !: QC flags for all levels for a variable
185
186	! Arrays with size equal to idefnqcf
187	! the number of profiles times number of variables
188	INTEGER, POINTER, DIMENSION(:,:) :: &
189	& nqcf, & !: Observation QC flags
190	& ipqcf, & !: Position QC flags
191	& itqcf !: Time QC flags
192
193	! Arrays with size equal to idefnqcf
194	! the number of profiles times number of variables
195	INTEGER, POINTER, DIMENSION(:,:,:) :: &
196	& ivqcf
197
198	! Arrays of variables
199
200	TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var
201
202	! Extra variables
203
204	TYPE(obs_prof_ext) :: vext
205
206	INTEGER :: nvprotext !: Local total number of extra variable profile data
207
208	INTEGER, POINTER, DIMENSION(:) :: &
209	& npvstaext, & !: Start of extra variable profiles in full arrays
210	& npvendext !: End of extra variable profiles in full arrays
211
212	! Arrays with size equal to the number of time steps in the window
213
214	INTEGER, POINTER, DIMENSION(:) :: &
215	& npstp, & !: Total number of profiles
216	& npstpmpp !: Total number of profiles
217
218	! Arrays with size equal to the number of time steps in the window times
219	! number of variables
220
221	INTEGER, POINTER, DIMENSION(:,:) :: &
222	& nvstp, & !: Local total num. of profile data each time step
223	& nvstpmpp !: Global total num. of profile data each time step
224
225	! Arrays with size equal to the number of grid points times number of
226	! variables
227
228	REAL(KIND=wp), POINTER, DIMENSION(:,:,:,:) :: &
229	& vdmean !: Daily averaged model field
230
231	! Arrays used to store source indices when
232	! compressing obs_prof derived types
233
234	! Array with size nprof
235
236	INTEGER, POINTER, DIMENSION(:) :: &
237	& npind !: Source indices of profile data in compressed data
238
239	END TYPE obs_prof
240
241	!!----------------------------------------------------------------------
242	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
243	!! $Id$
244	!! Software governed by the CeCILL license (see ./LICENSE)
245	!!----------------------------------------------------------------------
246
247	CONTAINS
248
249	SUBROUTINE obs_prof_alloc( prof, kvar, kadd, kext, kprof, &
250	& ko3dt, ke3dt, kstp, kpi, kpj, kpk )
251	!!----------------------------------------------------------------------
252	!! * ROUTINE obs_prof_alloc *
253	!!
254	!! ** Purpose : - Allocate data for profile arrays
255	!!
256	!! ** Method : - Fortran-90 dynamic arrays
257	!!
258	!! History :
259	!! ! 07-01 (K. Mogensen) Original code
260	!! ! 07-03 (K. Mogensen) Generalized profiles
261	!!----------------------------------------------------------------------
262	!! * Arguments
263	TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated
264	INTEGER, INTENT(IN) :: kprof ! Number of profiles
265	INTEGER, INTENT(IN) :: kvar ! Number of variables
266	INTEGER, INTENT(IN) :: kadd ! Number of additional fields within each variable
267	INTEGER, INTENT(IN) :: kext ! Number of extra fields
268	INTEGER, INTENT(IN), DIMENSION(kvar) :: &
269	& ko3dt ! Number of observations per variables
270	INTEGER, INTENT(IN) :: ke3dt ! Number of observations per extra variables
271	INTEGER, INTENT(IN) :: kstp ! Number of time steps
272	INTEGER, INTENT(IN) :: kpi ! Number of 3D grid points
273	INTEGER, INTENT(IN) :: kpj
274	INTEGER, INTENT(IN) :: kpk
275
276	!!* Local variables
277	INTEGER :: jvar, jadd, jext
278	INTEGER :: ji
279
280	! Set bookkeeping variables
281
282	prof%nvar = kvar
283	prof%nadd = kadd
284	prof%next = kext
285	prof%nprof = kprof
286
287	prof%nstp = kstp
288	prof%npi = kpi
289	prof%npj = kpj
290	prof%npk = kpk
291
292	! Allocate arrays of size number of variables
293
294	ALLOCATE( &
295	& prof%cvars(kvar), &
296	& prof%clong(kvar), &
297	& prof%cunit(kvar), &
298	& prof%cgrid(kvar), &
299	& prof%nvprot(kvar), &
300	& prof%nvprotmpp(kvar) &
301	)
302
303	DO jvar = 1, kvar
304	prof%cvars (jvar) = "NotSet"
305	prof%clong (jvar) = "NotSet"
306	prof%cunit (jvar) = "NotSet"
307	prof%cgrid (jvar) = ""
308	prof%nvprot (jvar) = ko3dt(jvar)
309	prof%nvprotmpp(jvar) = 0
310	END DO
311
312	! Allocate additional/extra variable metadata
313
314	ALLOCATE( &
315	& prof%caddvars(kadd), &
316	& prof%caddlong(kadd,kvar), &
317	& prof%caddunit(kadd,kvar), &
318	& prof%cextvars(kext), &
319	& prof%cextlong(kext), &
320	& prof%cextunit(kext) &
321	)
322
323	DO jadd = 1, kadd
324	prof%caddvars(jadd) = "NotSet"
325	DO jvar = 1, kvar
326	prof%caddlong(jadd,jvar) = "NotSet"
327	prof%caddunit(jadd,jvar) = "NotSet"
328	END DO
329	END DO
330
331	DO jext = 1, kext
332	prof%cextvars(jext) = "NotSet"
333	prof%cextlong(jext) = "NotSet"
334	prof%cextunit(jext) = "NotSet"
335	END DO
336
337	! Allocate arrays of size number of profiles
338	! times number of variables
339
340	ALLOCATE( &
341	& prof%npvsta(kprof,kvar), &
342	& prof%npvend(kprof,kvar), &
343	& prof%mi(kprof,kvar), &
344	& prof%mj(kprof,kvar), &
345	& prof%ivqc(kprof,kvar) &
346	)
347
348	! Allocate arrays of size iqcfdef times number of profiles
349	! times number of variables
350
351	ALLOCATE( &
352	& prof%ivqcf(idefnqcf,kprof,kvar) &
353	& )
354
355	! Allocate arrays of size number of profiles
356
357	ALLOCATE( &
358	& prof%npidx(kprof), &
359	& prof%npfil(kprof), &
360	& prof%nyea(kprof), &
361	& prof%nmon(kprof), &
362	& prof%nday(kprof), &
363	& prof%nhou(kprof), &
364	& prof%nmin(kprof), &
365	& prof%mstp(kprof), &
366	& prof%nqc(kprof), &
367	& prof%ipqc(kprof), &
368	& prof%itqc(kprof), &
369	& prof%ntyp(kprof), &
370	& prof%rlam(kprof), &
371	& prof%rphi(kprof), &
372	& prof%cwmo(kprof), &
373	& prof%npind(kprof) &
374	& )
375
376	! Allocate arrays of size idefnqcf times number of profiles
377
378	ALLOCATE( &
379	& prof%nqcf(idefnqcf,kprof), &
380	& prof%ipqcf(idefnqcf,kprof), &
381	& prof%itqcf(idefnqcf,kprof) &
382	& )
383
384	! Allocate obs_prof_var type
385	ALLOCATE( &
386	& prof%var(kvar) &
387	& )
388
389	! For each variables allocate arrays of size number of observations
390
391	DO jvar = 1, kvar
392	IF ( ko3dt(jvar) >= 0 ) THEN
393	CALL obs_prof_alloc_var( prof, jvar, kadd, ko3dt(jvar) )
394	ENDIF
395	END DO
396
397	! Extra variables
398
399	IF ( kext > 0 ) THEN
400	prof%nvprotext = ke3dt
401	ALLOCATE( &
402	& prof%npvstaext(kprof), &
403	& prof%npvendext(kprof) )
404	CALL obs_prof_alloc_ext( prof, kext, ke3dt )
405	ELSE
406	prof%nvprotext = 0
407	ENDIF
408
409	! Allocate arrays of size number of time step size
410
411	ALLOCATE( &
412	& prof%npstp(kstp), &
413	& prof%npstpmpp(kstp) &
414	& )
415
416	! Allocate arrays of size number of time step size times
417	! number of variables
418
419	ALLOCATE( &
420	& prof%nvstp(kstp,kvar), &
421	& prof%nvstpmpp(kstp,kvar) &
422	& )
423
424	! Allocate arrays of size number of grid points size times
425	! number of variables
426
427	ALLOCATE( &
428	& prof%vdmean(kpi,kpj,kpk,kvar) &
429	& )
430
431	! Set defaults for compression indices
432
433	DO ji = 1, kprof
434	prof%npind(ji) = ji
435	END DO
436
437	DO jvar = 1, kvar
438	DO ji = 1, ko3dt(jvar)
439	prof%var(jvar)%nvind(ji) = ji
440	END DO
441	END DO
442
443	IF ( kext > 0 ) THEN
444	DO ji = 1, ke3dt
445	prof%vext%neind(ji) = ji
446	END DO
447	ENDIF
448
449	! Set defaults for number of observations per time step
450
451	prof%npstp(:) = 0
452	prof%npstpmpp(:) = 0
453	prof%nvstp(:,:) = 0
454	prof%nvstpmpp(:,:) = 0
455
456	! Set the observation counter used in obs_oper
457
458	prof%nprofup = 0
459
460	END SUBROUTINE obs_prof_alloc
461
462	SUBROUTINE obs_prof_dealloc( prof )
463	!!----------------------------------------------------------------------
464	!! * ROUTINE obs_prof_dealloc *
465	!!
466	!! ** Purpose : - Deallocate data for profile arrays
467	!!
468	!! ** Method : - Fortran-90 dynamic arrays
469	!!
470	!! History :
471	!! ! 07-01 (K. Mogensen) Original code
472	!!----------------------------------------------------------------------
473	!! * Arguments
474	TYPE(obs_prof), INTENT(INOUT) :: &
475	& prof ! Profile data to be deallocated
476
477	!!* Local variables
478	INTEGER :: &
479	& jvar, &
480	& jext
481
482	! Deallocate arrays of size number of profiles
483	! times number of variables
484
485	DEALLOCATE( &
486	& prof%npvsta, &
487	& prof%npvend &
488	)
489
490	! Dellocate arrays of size number of profiles size
491
492	DEALLOCATE( &
493	& prof%mi, &
494	& prof%mj, &
495	& prof%ivqc, &
496	& prof%ivqcf, &
497	& prof%npidx, &
498	& prof%npfil, &
499	& prof%nyea, &
500	& prof%nmon, &
501	& prof%nday, &
502	& prof%nhou, &
503	& prof%nmin, &
504	& prof%mstp, &
505	& prof%nqc, &
506	& prof%ipqc, &
507	& prof%itqc, &
508	& prof%nqcf, &
509	& prof%ipqcf, &
510	& prof%itqcf, &
511	& prof%ntyp, &
512	& prof%rlam, &
513	& prof%rphi, &
514	& prof%cwmo, &
515	& prof%npind &
516	& )
517
518	! For each variables allocate arrays of size number of observations
519
520	DO jvar = 1, prof%nvar
521	IF ( prof%nvprot(jvar) >= 0 ) THEN
522	CALL obs_prof_dealloc_var( prof, jvar )
523	ENDIF
524	END DO
525
526	! Dellocate obs_prof_var type
527	DEALLOCATE( &
528	& prof%var &
529	& )
530
531	! Deallocate extra variables
532	IF ( prof%next > 0 ) THEN
533	DEALLOCATE( &
534	& prof%npvstaext, &
535	& prof%npvendext &
536	)
537	CALL obs_prof_dealloc_ext( prof )
538	ENDIF
539
540	! Deallocate arrays of size number of time step size
541
542	DEALLOCATE( &
543	& prof%npstp, &
544	& prof%npstpmpp &
545	& )
546
547	! Deallocate arrays of size number of time step size times
548	! number of variables
549
550	DEALLOCATE( &
551	& prof%nvstp, &
552	& prof%nvstpmpp &
553	& )
554
555	! Deallocate arrays of size number of grid points size times
556	! number of variables
557
558	DEALLOCATE( &
559	& prof%vdmean &
560	& )
561
562	! Dellocate arrays of size number of variables
563
564	DEALLOCATE( &
565	& prof%cvars, &
566	& prof%clong, &
567	& prof%cunit, &
568	& prof%cgrid, &
569	& prof%nvprot, &
570	& prof%nvprotmpp &
571	)
572
573	! Dellocate additional/extra variables metadata
574
575	DEALLOCATE( &
576	& prof%caddvars, &
577	& prof%caddlong, &
578	& prof%caddunit, &
579	& prof%cextvars, &
580	& prof%cextlong, &
581	& prof%cextunit &
582	)
583
584	END SUBROUTINE obs_prof_dealloc
585
586
587	SUBROUTINE obs_prof_alloc_var( prof, kvar, kadd, kobs )
588
589	!!----------------------------------------------------------------------
590	!! * ROUTINE obs_prof_alloc_var *
591	!!
592	!! ** Purpose : - Allocate data for variable data in profile arrays
593	!!
594	!! ** Method : - Fortran-90 dynamic arrays
595	!!
596	!! History :
597	!! ! 07-03 (K. Mogensen) Original code
598	!! * Arguments
599	TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated
600	INTEGER, INTENT(IN) :: kvar ! Variable number
601	INTEGER, INTENT(IN) :: kadd ! Number of additional fields within each variable
602	INTEGER, INTENT(IN) :: kobs ! Number of observations
603
604	ALLOCATE( &
605	& prof%var(kvar)%mvk(kobs), &
606	& prof%var(kvar)%nvpidx(kobs), &
607	& prof%var(kvar)%nvlidx(kobs), &
608	& prof%var(kvar)%nvqc(kobs), &
609	& prof%var(kvar)%idqc(kobs), &
610	& prof%var(kvar)%vdep(kobs), &
611	& prof%var(kvar)%vobs(kobs), &
612	& prof%var(kvar)%vmod(kobs), &
613	& prof%var(kvar)%nvind(kobs) &
614	& )
615	ALLOCATE( &
616	& prof%var(kvar)%idqcf(idefnqcf,kobs), &
617	& prof%var(kvar)%nvqcf(idefnqcf,kobs) &
618	& )
619	IF (kadd>0) THEN
620	ALLOCATE( &
621	& prof%var(kvar)%vadd(kobs,kadd) &
622	& )
623	ENDIF
624
625	END SUBROUTINE obs_prof_alloc_var
626
627
628	SUBROUTINE obs_prof_dealloc_var( prof, kvar )
629
630	!!----------------------------------------------------------------------
631	!! * ROUTINE obs_prof_dealloc_var *
632	!!
633	!! ** Purpose : - Deallocate data for variable data in profile arrays
634	!!
635	!! ** Method : - Fortran-90 dynamic arrays
636	!!
637	!! History :
638	!! ! 07-03 (K. Mogensen) Original code
639	!! * Arguments
640	TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be deallocated
641	INTEGER, INTENT(IN) :: kvar ! Variable number
642
643	DEALLOCATE( &
644	& prof%var(kvar)%mvk, &
645	& prof%var(kvar)%nvpidx, &
646	& prof%var(kvar)%nvlidx, &
647	& prof%var(kvar)%nvqc, &
648	& prof%var(kvar)%idqc, &
649	& prof%var(kvar)%vdep, &
650	& prof%var(kvar)%vobs, &
651	& prof%var(kvar)%vmod, &
652	& prof%var(kvar)%nvind, &
653	& prof%var(kvar)%idqcf, &
654	& prof%var(kvar)%nvqcf &
655	& )
656	IF (prof%nadd>0) THEN
657	DEALLOCATE( &
658	& prof%var(kvar)%vadd &
659	& )
660	ENDIF
661
662	END SUBROUTINE obs_prof_dealloc_var
663
664
665	SUBROUTINE obs_prof_alloc_ext( prof, kext, kobs )
666
667	!!----------------------------------------------------------------------
668	!! * ROUTINE obs_prof_alloc_ext *
669	!!
670	!! ** Purpose : - Allocate data for extra variables in profile arrays
671	!!
672	!! ** Method : - Fortran-90 dynamic arrays
673	!!
674	!! History :
675	!! ! 07-03 (K. Mogensen) Original code
676	!! * Arguments
677	TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be allocated
678	INTEGER, INTENT(IN) :: kext ! Number of extra variables
679	INTEGER, INTENT(IN) :: kobs ! Number of observations
680
681	ALLOCATE( &
682	& prof%vext%nepidx(kobs), &
683	& prof%vext%nelidx(kobs), &
684	& prof%vext%neind(kobs), &
685	& prof%vext%eobs(kobs,kext) &
686	& )
687
688	END SUBROUTINE obs_prof_alloc_ext
689
690
691	SUBROUTINE obs_prof_dealloc_ext( prof )
692
693	!!----------------------------------------------------------------------
694	!! * ROUTINE obs_prof_dealloc_var *
695	!!
696	!! ** Purpose : - Deallocate data for extra variables in profile arrays
697	!!
698	!! ** Method : - Fortran-90 dynamic arrays
699	!!
700	!! History :
701	!! ! 07-03 (K. Mogensen) Original code
702	!! * Arguments
703	TYPE(obs_prof), INTENT(INOUT) :: prof ! Profile data to be deallocated
704
705	DEALLOCATE( &
706	& prof%vext%nepidx, &
707	& prof%vext%nelidx, &
708	& prof%vext%eobs, &
709	& prof%vext%neind &
710	& )
711
712	END SUBROUTINE obs_prof_dealloc_ext
713
714
715	SUBROUTINE obs_prof_compress( prof, newprof, lallocate, &
716	& kumout, lvalid, lvvalid )
717	!!----------------------------------------------------------------------
718	!! * ROUTINE obs_prof_compress *
719	!!
720	!! ** Purpose : - Extract sub-information from a obs_prof type
721	!! into a new obs_prof type
722	!!
723	!! ** Method : - The data is copied from prof to new prof.
724	!! In the case of lvalid and lvvalid both being
725	!! present only the selected data will be copied.
726	!! If lallocate is true the data in the newprof is
727	!! allocated either with the same number of elements
728	!! as prof or with only the subset of elements defined
729	!! by the optional selection in lvalid and lvvalid
730	!!
731	!! History :
732	!! ! 07-01 (K. Mogensen) Original code
733	!!----------------------------------------------------------------------
734	!! * Arguments
735	TYPE(obs_prof), INTENT(IN) :: prof ! Original profile
736	TYPE(obs_prof), INTENT(INOUT) :: newprof ! New profile with the copy of the data
737	LOGICAL, INTENT(IN) :: lallocate ! Allocate newprof data
738	INTEGER, INTENT(IN) :: kumout ! Fortran unit for messages
739	TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: &
740	& lvalid ! Valid profiles
741	TYPE(obs_prof_valid), OPTIONAL, INTENT(in), DIMENSION(prof%nvar) :: &
742	& lvvalid ! Valid data within the profiles
743
744	!!* Local variables
745	INTEGER :: inprof
746	INTEGER, DIMENSION(prof%nvar) :: &
747	& invpro
748	INTEGER :: invproext
749	INTEGER :: jvar
750	INTEGER :: jadd
751	INTEGER :: jext
752	INTEGER :: ji
753	INTEGER :: jj
754	LOGICAL :: lfirst
755	TYPE(obs_prof_valid) :: &
756	& llvalid
757	TYPE(obs_prof_valid), DIMENSION(prof%nvar) :: &
758	& llvvalid
759	LOGICAL :: lallpresent
760	LOGICAL :: lnonepresent
761
762	! Check that either all or none of the masks are present.
763
764	lallpresent = .FALSE.
765	lnonepresent = .FALSE.
766	IF ( PRESENT(lvalid) .AND. PRESENT(lvvalid) ) THEN
767	lallpresent = .TRUE.
768	ELSEIF ( ( .NOT. PRESENT(lvalid) ) .AND. &
769	& ( .NOT. PRESENT(lvvalid) ) ) THEN
770	lnonepresent = .TRUE.
771	ELSE
772	CALL ctl_stop('Error in obs_prof_compress:', &
773	& 'Either all selection variables should be set', &
774	& 'or no selection variable should be set' )
775	ENDIF
776
777	! Count how many elements there should be in the new data structure
778
779	IF ( lallpresent ) THEN
780	inprof = 0
781	invpro(:) = 0
782	invproext = 0
783	DO ji = 1, prof%nprof
784	IF ( lvalid%luse(ji) ) THEN
785	inprof = inprof + 1
786	DO jvar = 1, prof%nvar
787	DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
788	IF ( lvvalid(jvar)%luse(jj) ) &
789	& invpro(jvar) = invpro(jvar) +1
790	END DO
791	END DO
792	IF ( prof%next > 0 ) THEN
793	DO jj = prof%npvstaext(ji), prof%npvendext(ji)
794	invproext = invproext + 1
795	END DO
796	ENDIF
797	ENDIF
798	END DO
799	ELSE
800	inprof = prof%nprof
801	invpro(:) = prof%nvprot(:)
802	invproext = prof%nvprotext
803	ENDIF
804
805	! Optionally allocate data in the new data structure
806
807	IF ( lallocate ) THEN
808	CALL obs_prof_alloc( newprof, prof%nvar, &
809	& prof%nadd, prof%next, &
810	& inprof, invpro, &
811	& invproext, &
812	& prof%nstp, prof%npi, &
813	& prof%npj, prof%npk )
814	ENDIF
815
816	! Allocate temporary mask array to unify the code for both cases
817
818	ALLOCATE( llvalid%luse(prof%nprof) )
819	DO jvar = 1, prof%nvar
820	ALLOCATE( llvvalid(jvar)%luse(prof%nvprot(jvar)) )
821	END DO
822	IF ( lallpresent ) THEN
823	llvalid%luse(:) = lvalid%luse(:)
824	DO jvar = 1, prof%nvar
825	llvvalid(jvar)%luse(:) = lvvalid(jvar)%luse(:)
826	END DO
827	ELSE
828	llvalid%luse(:) = .TRUE.
829	DO jvar = 1, prof%nvar
830	llvvalid(jvar)%luse(:) = .TRUE.
831	END DO
832	ENDIF
833
834	! Setup bookkeeping variables
835
836	inprof = 0
837	invpro(:) = 0
838	invproext = 0
839
840	newprof%npvsta(:,:) = 0
841	newprof%npvend(:,:) = -1
842	newprof%npvstaext(:) = 0
843	newprof%npvendext(:) = -1
844
845	! Loop over source profiles
846
847	DO ji = 1, prof%nprof
848
849	IF ( llvalid%luse(ji) ) THEN
850
851	! Copy the header information
852
853	inprof = inprof + 1
854
855	newprof%mi(inprof,:) = prof%mi(ji,:)
856	newprof%mj(inprof,:) = prof%mj(ji,:)
857	newprof%npidx(inprof) = prof%npidx(ji)
858	newprof%npfil(inprof) = prof%npfil(ji)
859	newprof%nyea(inprof) = prof%nyea(ji)
860	newprof%nmon(inprof) = prof%nmon(ji)
861	newprof%nday(inprof) = prof%nday(ji)
862	newprof%nhou(inprof) = prof%nhou(ji)
863	newprof%nmin(inprof) = prof%nmin(ji)
864	newprof%mstp(inprof) = prof%mstp(ji)
865	newprof%nqc(inprof) = prof%nqc(ji)
866	newprof%ipqc(inprof) = prof%ipqc(ji)
867	newprof%itqc(inprof) = prof%itqc(ji)
868	newprof%ivqc(inprof,:)= prof%ivqc(ji,:)
869	newprof%ntyp(inprof) = prof%ntyp(ji)
870	newprof%rlam(inprof) = prof%rlam(ji)
871	newprof%rphi(inprof) = prof%rphi(ji)
872	newprof%cwmo(inprof) = prof%cwmo(ji)
873
874	! QC info
875
876	newprof%nqcf(:,inprof) = prof%nqcf(:,ji)
877	newprof%ipqcf(:,inprof) = prof%ipqcf(:,ji)
878	newprof%itqcf(:,inprof) = prof%itqcf(:,ji)
879	newprof%ivqcf(:,inprof,:) = prof%ivqcf(:,ji,:)
880
881	! npind is the index of the original profile
882
883	newprof%npind(inprof) = ji
884
885	! Copy the variable information
886
887	DO jvar = 1, prof%nvar
888
889	lfirst = .TRUE.
890
891	DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
892
893	IF ( llvvalid(jvar)%luse(jj) ) THEN
894
895	invpro(jvar) = invpro(jvar) + 1
896
897	! Book keeping information
898
899	IF ( lfirst ) THEN
900	lfirst = .FALSE.
901	newprof%npvsta(inprof,jvar) = invpro(jvar)
902	ENDIF
903	newprof%npvend(inprof,jvar) = invpro(jvar)
904
905	! Variable data
906
907	newprof%var(jvar)%mvk(invpro(jvar)) = &
908	& prof%var(jvar)%mvk(jj)
909	newprof%var(jvar)%nvpidx(invpro(jvar)) = &
910	& prof%var(jvar)%nvpidx(jj)
911	newprof%var(jvar)%nvlidx(invpro(jvar)) = &
912	& prof%var(jvar)%nvlidx(jj)
913	newprof%var(jvar)%nvqc(invpro(jvar)) = &
914	& prof%var(jvar)%nvqc(jj)
915	newprof%var(jvar)%idqc(invpro(jvar)) = &
916	& prof%var(jvar)%idqc(jj)
917	newprof%var(jvar)%idqcf(:,invpro(jvar))= &
918	& prof%var(jvar)%idqcf(:,jj)
919	newprof%var(jvar)%nvqcf(:,invpro(jvar))= &
920	& prof%var(jvar)%nvqcf(:,jj)
921	newprof%var(jvar)%vdep(invpro(jvar)) = &
922	& prof%var(jvar)%vdep(jj)
923	newprof%var(jvar)%vobs(invpro(jvar)) = &
924	& prof%var(jvar)%vobs(jj)
925	newprof%var(jvar)%vmod(invpro(jvar)) = &
926	& prof%var(jvar)%vmod(jj)
927	DO jadd = 1, prof%nadd
928	newprof%var(jvar)%vadd(invpro(jvar),jadd) = &
929	& prof%var(jvar)%vadd(jj,jadd)
930	END DO
931
932	! nvind is the index of the original variable data
933
934	newprof%var(jvar)%nvind(invpro(jvar)) = jj
935
936	ENDIF
937
938	END DO
939
940	END DO
941
942	IF ( prof%next > 0 ) THEN
943
944	! Extra variables
945
946	lfirst = .TRUE.
947
948	DO jj = prof%npvstaext(ji), prof%npvendext(ji)
949
950	invproext = invproext + 1
951
952	! Book keeping information
953
954	IF ( lfirst ) THEN
955	lfirst = .FALSE.
956	newprof%npvstaext(inprof) = invproext
957	ENDIF
958	newprof%npvendext(inprof) = invproext
959
960	! Variable data
961
962	newprof%vext%nepidx(invproext) = prof%vext%nepidx(jj)
963	newprof%vext%nelidx(invproext) = prof%vext%nelidx(jj)
964	DO jext = 1, prof%next
965	newprof%vext%eobs(invproext,jext) = prof%vext%eobs(jj,jext)
966	END DO
967
968	! nvind is the index of the original variable data
969
970	newprof%vext%neind(invproext) = jj
971
972	END DO
973
974	ENDIF
975
976	ENDIF
977
978	END DO
979
980	! Update MPP counters
981
982	DO jvar = 1, prof%nvar
983	newprof%nvprot(jvar) = invpro(jvar)
984	END DO
985	CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,&
986	& prof%nvar )
987	newprof%nvprotext = invproext
988
989	! Set book keeping variables which do not depend on number of obs.
990
991	newprof%nvar = prof%nvar
992	newprof%nadd = prof%nadd
993	newprof%next = prof%next
994	newprof%nstp = prof%nstp
995	newprof%npi = prof%npi
996	newprof%npj = prof%npj
997	newprof%npk = prof%npk
998	newprof%cvars(:) = prof%cvars(:)
999	newprof%clong(:) = prof%clong(:)
1000	newprof%cunit(:) = prof%cunit(:)
1001	newprof%cgrid(:) = prof%cgrid(:)
1002	newprof%caddvars(:) = prof%caddvars(:)
1003	newprof%caddlong(:,:) = prof%caddlong(:,:)
1004	newprof%caddunit(:,:) = prof%caddunit(:,:)
1005	newprof%cextvars(:) = prof%cextvars(:)
1006	newprof%cextlong(:) = prof%cextlong(:)
1007	newprof%cextunit(:) = prof%cextunit(:)
1008
1009	! Deallocate temporary data
1010
1011	DO jvar = 1, prof%nvar
1012	DEALLOCATE( llvvalid(jvar)%luse )
1013	END DO
1014
1015	DEALLOCATE( llvalid%luse )
1016
1017	END SUBROUTINE obs_prof_compress
1018
1019	SUBROUTINE obs_prof_decompress( prof, oldprof, ldeallocate, kumout )
1020	!!----------------------------------------------------------------------
1021	!! * ROUTINE obs_prof_decompress *
1022	!!
1023	!! ** Purpose : - Copy back information to original profile type
1024	!!
1025	!! ** Method : - Reinsert updated information from a previous
1026	!! copied/compressed profile type into the original
1027	!! profile data and optionally deallocate the prof
1028	!! data input
1029	!!
1030	!! History :
1031	!! ! 07-01 (K. Mogensen) Original code
1032	!!----------------------------------------------------------------------
1033	!! * Arguments
1034	TYPE(obs_prof),INTENT(INOUT) :: prof ! Updated profile data
1035	TYPE(obs_prof),INTENT(INOUT) :: oldprof ! Original profile data
1036	LOGICAL :: ldeallocate ! Deallocate the updated data of insertion
1037	INTEGER,INTENT(in) :: kumout ! Output unit
1038
1039	!!* Local variables
1040	INTEGER :: jvar
1041	INTEGER :: jadd
1042	INTEGER :: jext
1043	INTEGER :: ji
1044	INTEGER :: jj
1045	INTEGER :: jk
1046	INTEGER :: jl
1047
1048	DO ji = 1, prof%nprof
1049
1050	! Copy header information
1051
1052	jk = prof%npind(ji)
1053
1054	oldprof%mi(jk,:) = prof%mi(ji,:)
1055	oldprof%mj(jk,:) = prof%mj(ji,:)
1056	oldprof%npidx(jk) = prof%npidx(ji)
1057	oldprof%npfil(jk) = prof%npfil(ji)
1058	oldprof%nyea(jk) = prof%nyea(ji)
1059	oldprof%nmon(jk) = prof%nmon(ji)
1060	oldprof%nday(jk) = prof%nday(ji)
1061	oldprof%nhou(jk) = prof%nhou(ji)
1062	oldprof%nmin(jk) = prof%nmin(ji)
1063	oldprof%mstp(jk) = prof%mstp(ji)
1064	oldprof%nqc(jk) = prof%nqc(ji)
1065	oldprof%ipqc(jk) = prof%ipqc(ji)
1066	oldprof%itqc(jk) = prof%itqc(ji)
1067	oldprof%ivqc(jk,:)= prof%ivqc(ji,:)
1068	oldprof%ntyp(jk) = prof%ntyp(ji)
1069	oldprof%rlam(jk) = prof%rlam(ji)
1070	oldprof%rphi(jk) = prof%rphi(ji)
1071	oldprof%cwmo(jk) = prof%cwmo(ji)
1072
1073	! QC info
1074
1075	oldprof%nqcf(:,jk) = prof%nqcf(:,ji)
1076	oldprof%ipqcf(:,jk) = prof%ipqcf(:,ji)
1077	oldprof%itqcf(:,jk) = prof%itqcf(:,ji)
1078	oldprof%ivqcf(:,jk,:) = prof%ivqcf(:,ji,:)
1079
1080	! Copy the variable information
1081
1082	DO jvar = 1, prof%nvar
1083
1084	DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
1085
1086	jl = prof%var(jvar)%nvind(jj)
1087
1088	oldprof%var(jvar)%mvk(jl) = prof%var(jvar)%mvk(jj)
1089	oldprof%var(jvar)%nvpidx(jl) = prof%var(jvar)%nvpidx(jj)
1090	oldprof%var(jvar)%nvlidx(jl) = prof%var(jvar)%nvlidx(jj)
1091	oldprof%var(jvar)%nvqc(jl) = prof%var(jvar)%nvqc(jj)
1092	oldprof%var(jvar)%idqc(jl) = prof%var(jvar)%idqc(jj)
1093	oldprof%var(jvar)%vdep(jl) = prof%var(jvar)%vdep(jj)
1094	oldprof%var(jvar)%vobs(jl) = prof%var(jvar)%vobs(jj)
1095	oldprof%var(jvar)%vmod(jl) = prof%var(jvar)%vmod(jj)
1096	oldprof%var(jvar)%idqcf(:,jl) = prof%var(jvar)%idqcf(:,jj)
1097	oldprof%var(jvar)%nvqcf(:,jl) = prof%var(jvar)%nvqcf(:,jj)
1098	DO jadd = 1, prof%nadd
1099	oldprof%var(jvar)%vadd(jl,jadd) = &
1100	& prof%var(jvar)%vadd(jj,jadd)
1101	END DO
1102
1103	END DO
1104
1105	END DO
1106
1107	IF ( prof%next > 0 ) THEN
1108
1109	DO jj = prof%npvstaext(ji), prof%npvendext(ji)
1110
1111	jl = prof%vext%neind(jj)
1112
1113	oldprof%vext%nepidx(jl) = prof%vext%nepidx(jj)
1114	oldprof%vext%nelidx(jl) = prof%vext%nelidx(jj)
1115	DO jext = 1, prof%next
1116	oldprof%vext%eobs(jl,jext) = prof%vext%eobs(jj,jext)
1117	END DO
1118
1119	END DO
1120
1121	ENDIF
1122
1123	END DO
1124
1125	! Optionally deallocate the updated profile data
1126
1127	IF ( ldeallocate ) CALL obs_prof_dealloc( prof )
1128
1129	END SUBROUTINE obs_prof_decompress
1130
1131
1132	SUBROUTINE obs_prof_staend( prof, kvarno )
1133	!!----------------------------------------------------------------------
1134	!! * ROUTINE obs_prof_staend *
1135	!!
1136	!! ** Purpose : - Set npvsta and npvend of a variable within
1137	!! an obs_prof_var type
1138	!!
1139	!! ** Method : - Find the start and stop of a profile by searching
1140	!! through the data
1141	!!
1142	!! History :
1143	!! ! 07-04 (K. Mogensen) Original code
1144	!!----------------------------------------------------------------------
1145	!! * Arguments
1146	TYPE(obs_prof),INTENT(INOUT) :: prof ! Profile data
1147	INTEGER,INTENT(IN) :: kvarno ! Variable number
1148
1149	!!* Local variables
1150	INTEGER :: ji
1151	INTEGER :: iprofno
1152
1153	!-----------------------------------------------------------------------
1154	! Compute start and end bookkeeping arrays
1155	!-----------------------------------------------------------------------
1156
1157	prof%npvsta(:,kvarno) = prof%nvprot(kvarno) + 1
1158	prof%npvend(:,kvarno) = -1
1159	DO ji = 1, prof%nvprot(kvarno)
1160	iprofno = prof%var(kvarno)%nvpidx(ji)
1161	prof%npvsta(iprofno,kvarno) = &
1162	& MIN( ji, prof%npvsta(iprofno,kvarno) )
1163	prof%npvend(iprofno,kvarno) = &
1164	& MAX( ji, prof%npvend(iprofno,kvarno) )
1165	END DO
1166
1167	DO ji = 1, prof%nprof
1168	IF ( prof%npvsta(ji,kvarno) == ( prof%nvprot(kvarno) + 1 ) ) &
1169	& prof%npvsta(ji,kvarno) = 0
1170	END DO
1171
1172	END SUBROUTINE obs_prof_staend
1173
1174
1175	SUBROUTINE obs_prof_staend_ext( prof )
1176	!!----------------------------------------------------------------------
1177	!! * ROUTINE obs_prof_staend_ext *
1178	!!
1179	!! ** Purpose : - Set npvsta and npvend within
1180	!! an obs_prof_ext type
1181	!!
1182	!! ** Method : - Find the start and stop of a profile by searching
1183	!! through the data
1184	!!
1185	!! History :
1186	!! ! 07-04 (K. Mogensen) Original code
1187	!!----------------------------------------------------------------------
1188	!! * Arguments
1189	TYPE(obs_prof),INTENT(INOUT) :: prof ! Profile data
1190
1191	!!* Local variables
1192	INTEGER :: ji
1193	INTEGER :: iprofno
1194
1195	!-----------------------------------------------------------------------
1196	! Compute start and end bookkeeping arrays
1197	!-----------------------------------------------------------------------
1198
1199	prof%npvstaext(:) = prof%nvprotext + 1
1200	prof%npvendext(:) = -1
1201	DO ji = 1, prof%nvprotext
1202	iprofno = prof%vext%nepidx(ji)
1203	prof%npvstaext(iprofno) = &
1204	& MIN( ji, prof%npvstaext(iprofno) )
1205	prof%npvendext(iprofno) = &
1206	& MAX( ji, prof%npvendext(iprofno) )
1207	END DO
1208
1209	DO ji = 1, prof%nprof
1210	IF ( prof%npvstaext(ji) == ( prof%nvprotext + 1 ) ) &
1211	& prof%npvstaext(ji) = 0
1212	END DO
1213
1214	END SUBROUTINE obs_prof_staend_ext
1215
1216	END MODULE obs_profiles_def
1217

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

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

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_profiles_def.F90 @ 15497

Download in other formats: