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_profiles_def.F90 in branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/UKMO/dev_r5518_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90 @ 11468

Last change on this file since 11468 was 11468, checked in by mattmartin, 5 years ago

Merged changes to allow writing of climatological information to feedback files.

File size: 32.0 KB
Line 
1MODULE 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_dealloc,   &
46      & obs_prof_compress,  &
47      & obs_prof_decompress,&
48      & obs_prof_staend
49
50   !! * Type definition for valid observations
51
52   TYPE obs_prof_valid
53     
54      LOGICAL, POINTER, DIMENSION(:) :: luse
55
56   END TYPE obs_prof_valid
57
58   !! * Type definition for each variable
59
60   TYPE obs_prof_var
61
62      ! Arrays with size equal to the number of observations
63
64      INTEGER, POINTER, DIMENSION(:) :: &
65         & mvk,   &       !: k-th grid coord. for interpolating to profile data
66         & nvpidx,&       !: Profile number
67         & nvlidx,&       !: Level number in profile
68         & nvqc,  &       !: Variable QC flags
69         & idqc           !: Depth QC flag
70
71      REAL(KIND=wp), POINTER, DIMENSION(:) :: &
72         & vdep,  &       !: Depth coordinate of profile data
73         & vobs,  &       !: Profile data
74         & vmod,  &       !: Model counterpart of the profile data vector
75         & vclm           !: Climatological counterpart of the profile data vector
76         
77      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: &
78         & vext           !: Extra variables
79
80      INTEGER, POINTER, DIMENSION(:) :: &
81         & nvind          !: Source indices of temp. data in compressed data
82
83      ! Arrays with size equal to idefnqcf times the number of observations
84      INTEGER, POINTER, DIMENSION(:,:) :: &
85         & idqcf,  &      !: Depth QC flags
86         & nvqcf          !: Variable QC flags
87
88   END TYPE obs_prof_var
89
90   !! * Type definition for profile observation type
91
92   TYPE obs_prof
93
94      ! Bookkeeping
95
96      INTEGER :: nvar     !: Number of variables
97      INTEGER :: next     !: Number of extra fields
98      INTEGER :: nprof    !: Total number of profiles within window.
99      INTEGER :: nstp     !: Number of time steps
100      INTEGER :: npi      !: Number of 3D grid points
101      INTEGER :: npj
102      INTEGER :: npk
103      INTEGER :: nprofup  !: Observation counter used in obs_oper
104
105      LOGICAL :: lclim    !: Climatology will be calculated for this structure
106     
107      ! Bookkeeping arrays with sizes equal to number of variables
108
109      CHARACTER(len=8), POINTER, DIMENSION(:) :: &
110         & cvars          !: Variable names
111
112      INTEGER, POINTER, DIMENSION(:) :: &
113         & nvprot,   &    !: Local total number of profile T data
114         & nvprotmpp      !: Global total number of profile T data
115     
116      ! Arrays with size equal to the number of profiles
117
118      INTEGER, POINTER, DIMENSION(:) :: &
119         & npidx,&        !: Profile number
120         & npfil,&        !: Profile number in file
121         & nyea, &        !: Year of profile
122         & nmon, &        !: Month of profile
123         & nday, &        !: Day of profile
124         & nhou, &        !: Hour of profile
125         & nmin, &        !: Minute of profile
126         & mstp, &        !: Time step nearest to profile
127         & nqc,  &        !: Profile QC
128         & ntyp, &        !: Type of profile product (WMO table 1770)
129         & ipqc, &        !: Position QC
130         & itqc           !: Time QC
131
132      REAL(KIND=wp), POINTER, DIMENSION(:) :: &
133         & rlam, &        !: Longitude coordinate of profile data
134         & rphi           !: Latitude coordinate of profile data
135
136      CHARACTER(LEN=8), POINTER, DIMENSION(:) :: &
137         & cwmo           !: Profile WMO indentifier
138     
139      ! Arrays with size equal to the number of profiles times
140      ! number of variables
141
142      INTEGER, POINTER, DIMENSION(:,:) :: &
143         & npvsta, &      !: Start of each variable profile in full arrays
144         & npvend, &      !: End of each variable profile in full arrays
145         & mi,     &      !: i-th grid coord. for interpolating to profile T data
146         & mj,     &      !: j-th grid coord. for interpolating to profile T data
147         & ivqc           !: QC flags for all levels for a variable
148
149      ! Arrays with size equal to idefnqcf
150      ! the number of profiles times number of variables
151      INTEGER, POINTER, DIMENSION(:,:) :: &
152         & nqcf,  &       !: Observation QC flags
153         & ipqcf, &       !: Position QC flags
154         & itqcf          !: Time QC flags
155
156      ! Arrays with size equal to idefnqcf
157      ! the number of profiles times number of variables
158      INTEGER, POINTER, DIMENSION(:,:,:) :: &
159         & ivqcf
160
161      ! Arrays of variables
162
163      TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var
164
165      ! Arrays with size equal to the number of time steps in the window
166
167      INTEGER, POINTER, DIMENSION(:) :: &
168         & npstp,    &    !: Total number of profiles
169         & npstpmpp       !: Total number of profiles
170
171      ! Arrays with size equal to the number of time steps in the window times
172      ! number of variables
173
174      INTEGER, POINTER, DIMENSION(:,:) :: &
175         & nvstp,    &    !: Local total num. of profile data each time step
176         & nvstpmpp       !: Global total num. of profile data each time step
177     
178      ! Arrays with size equal to the number of grid points times number of
179      ! variables
180
181      REAL(KIND=wp), POINTER, DIMENSION(:,:,:,:) :: &
182         & vdmean        !: Daily averaged model field
183
184      ! Arrays used to store source indices when
185      ! compressing obs_prof derived types
186     
187      ! Array with size nprof
188
189      INTEGER, POINTER, DIMENSION(:) :: &
190         & npind         !: Source indices of profile data in compressed data
191
192   END TYPE obs_prof
193
194   !!----------------------------------------------------------------------
195   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
196   !! $Id$
197   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
198   !!----------------------------------------------------------------------
199
200CONTAINS
201   
202   SUBROUTINE obs_prof_alloc( prof,  kvar, kext, kprof,  &
203      &                       ko3dt, kstp, kpi, kpj, kpk, ldclim )
204      !!----------------------------------------------------------------------
205      !!                     ***  ROUTINE obs_prof_alloc  ***
206      !!                     
207      !! ** Purpose : - Allocate data for profile arrays
208      !!
209      !! ** Method  : - Fortran-90 dynamic arrays
210      !!
211      !! History :
212      !!        !  07-01  (K. Mogensen) Original code
213      !!        !  07-03  (K. Mogensen) Generalized profiles
214      !!----------------------------------------------------------------------
215      !! * Arguments
216      TYPE(obs_prof), INTENT(INOUT) :: prof      ! Profile data to be allocated
217      INTEGER, INTENT(IN) :: kprof  ! Number of profiles
218      INTEGER, INTENT(IN) :: kvar   ! Number of variables
219      INTEGER, INTENT(IN) :: kext   ! Number of extra fields within each variable
220      INTEGER, INTENT(IN), DIMENSION(kvar) :: &
221         & ko3dt     ! Number of observations per variables
222      INTEGER, INTENT(IN) :: kstp   ! Number of time steps
223      INTEGER, INTENT(IN) :: kpi    ! Number of 3D grid points
224      INTEGER, INTENT(IN) :: kpj
225      INTEGER, INTENT(IN) :: kpk
226      LOGICAL, INTENT(IN) :: ldclim
227
228      !!* Local variables
229      INTEGER :: jvar
230      INTEGER :: ji
231
232      ! Set bookkeeping variables
233
234      prof%nvar      = kvar
235      prof%next      = kext
236      prof%nprof     = kprof
237
238      prof%nstp      = kstp
239      prof%npi       = kpi
240      prof%npj       = kpj
241      prof%npk       = kpk
242     
243      prof%lclim     = ldclim
244
245      ! Allocate arrays of size number of variables
246
247      ALLOCATE( &
248         & prof%cvars(kvar),    &
249         & prof%nvprot(kvar),   &
250         & prof%nvprotmpp(kvar) &
251         )
252         
253      DO jvar = 1, kvar
254         prof%cvars    (jvar) = "NotSet"
255         prof%nvprot   (jvar) = ko3dt(jvar)
256         prof%nvprotmpp(jvar) = 0
257      END DO
258
259      ! Allocate arrays of size number of profiles
260      ! times number of variables
261     
262      ALLOCATE( &
263         & prof%npvsta(kprof,kvar), & 
264         & prof%npvend(kprof,kvar), &
265         & prof%mi(kprof,kvar),     &
266         & prof%mj(kprof,kvar),     &
267         & prof%ivqc(kprof,kvar)    &
268         )
269
270      ! Allocate arrays of size iqcfdef times number of profiles
271      ! times number of variables
272
273      ALLOCATE( &
274         & prof%ivqcf(idefnqcf,kprof,kvar) &
275         & )
276
277      ! Allocate arrays of size number of profiles
278
279      ALLOCATE( &
280         & prof%npidx(kprof),   &
281         & prof%npfil(kprof),   &
282         & prof%nyea(kprof),    &
283         & prof%nmon(kprof),    &
284         & prof%nday(kprof),    &
285         & prof%nhou(kprof),    &
286         & prof%nmin(kprof),    &
287         & prof%mstp(kprof),    &
288         & prof%nqc(kprof),     &
289         & prof%ipqc(kprof),    &
290         & prof%itqc(kprof),    &
291         & prof%ntyp(kprof),    &
292         & prof%rlam(kprof),    &
293         & prof%rphi(kprof),    &
294         & prof%cwmo(kprof),    &
295         & prof%npind(kprof)    &
296         & )
297
298      ! Allocate arrays of size idefnqcf times number of profiles
299
300      ALLOCATE( &
301         & prof%nqcf(idefnqcf,kprof),  &
302         & prof%ipqcf(idefnqcf,kprof), &
303         & prof%itqcf(idefnqcf,kprof)  &
304         & )
305
306      ! Allocate obs_prof_var type
307      ALLOCATE( &
308         & prof%var(kvar) &
309         & )
310
311      ! For each variables allocate arrays of size number of observations
312
313      DO jvar = 1, kvar
314
315         IF ( ko3dt(jvar) >= 0 ) THEN
316            CALL obs_prof_alloc_var( prof, jvar, kext, ko3dt(jvar) )
317         ENDIF
318         
319      END DO
320
321      ! Allocate arrays of size number of time step size
322
323      ALLOCATE( &
324         & prof%npstp(kstp),   &
325         & prof%npstpmpp(kstp) &
326         & )
327
328      ! Allocate arrays of size number of time step size times
329      ! number of variables
330     
331      ALLOCATE( &
332         & prof%nvstp(kstp,kvar),   &
333         & prof%nvstpmpp(kstp,kvar) &
334         & )
335
336      ! Allocate arrays of size number of grid points size times
337      ! number of variables
338
339      ALLOCATE( &
340         & prof%vdmean(kpi,kpj,kpk,kvar) &
341         & )
342
343      ! Set defaults for compression indices
344     
345      DO ji = 1, kprof
346         prof%npind(ji) = ji
347      END DO
348
349      DO jvar = 1, kvar
350         DO ji = 1, ko3dt(jvar)
351            prof%var(jvar)%nvind(ji) = ji
352         END DO
353      END DO
354
355      ! Set defaults for number of observations per time step
356
357      prof%npstp(:)      = 0
358      prof%npstpmpp(:)   = 0
359      prof%nvstp(:,:)    = 0
360      prof%nvstpmpp(:,:) = 0
361     
362      ! Set the observation counter used in obs_oper
363
364      prof%nprofup     = 0
365
366   END SUBROUTINE obs_prof_alloc
367
368   SUBROUTINE obs_prof_dealloc( prof )
369      !!----------------------------------------------------------------------
370      !!                     ***  ROUTINE obs_prof_dealloc  ***
371      !!                     
372      !! ** Purpose : - Deallocate data for profile arrays
373      !!
374      !! ** Method  : - Fortran-90 dynamic arrays
375      !!
376      !! History :
377      !!        !  07-01  (K. Mogensen) Original code
378      !!----------------------------------------------------------------------
379      !! * Arguments
380      TYPE(obs_prof), INTENT(INOUT) :: &
381         & prof      ! Profile data to be deallocated
382
383      !!* Local variables
384      INTEGER :: &
385         & jvar
386
387      ! Deallocate arrays of size number of profiles
388      ! times number of variables
389     
390      DEALLOCATE( &
391         & prof%npvsta, & 
392         & prof%npvend  &
393         )
394
395      ! Dellocate arrays of size number of profiles size
396
397      DEALLOCATE( &
398         & prof%mi,      &
399         & prof%mj,      &
400         & prof%ivqc,    &
401         & prof%ivqcf,   &
402         & prof%npidx,   &
403         & prof%npfil,   &
404         & prof%nyea,    &
405         & prof%nmon,    &
406         & prof%nday,    &
407         & prof%nhou,    &
408         & prof%nmin,    &
409         & prof%mstp,    &
410         & prof%nqc,     &
411         & prof%ipqc,    &
412         & prof%itqc,    &
413         & prof%nqcf,    &
414         & prof%ipqcf,   &
415         & prof%itqcf,   &
416         & prof%ntyp,    &
417         & prof%rlam,    &
418         & prof%rphi,    &
419         & prof%cwmo,    &
420         & prof%npind    &
421         & )
422
423      ! For each variables allocate arrays of size number of observations
424
425      DO jvar = 1, prof%nvar
426
427         IF ( prof%nvprot(jvar) >= 0 ) THEN
428
429            CALL obs_prof_dealloc_var( prof, jvar )
430
431         ENDIF
432         
433      END DO
434
435      ! Dellocate obs_prof_var type
436      DEALLOCATE( &
437         & prof%var &
438         & )
439
440      ! Deallocate arrays of size number of time step size
441
442      DEALLOCATE( &
443         & prof%npstp,   &
444         & prof%npstpmpp &
445         & )
446
447      ! Deallocate arrays of size number of time step size times
448      ! number of variables
449     
450      DEALLOCATE( &
451         & prof%nvstp,   &
452         & prof%nvstpmpp &
453         & )
454
455      ! Deallocate arrays of size number of grid points size times
456      ! number of variables
457
458      DEALLOCATE( &
459         & prof%vdmean &
460         & )
461
462      ! Dellocate arrays of size number of variables
463
464      DEALLOCATE( &
465         & prof%cvars,    &
466         & prof%nvprot,   &
467         & prof%nvprotmpp &
468         )
469
470
471   END SUBROUTINE obs_prof_dealloc
472
473
474   SUBROUTINE obs_prof_alloc_var( prof, kvar, kext, kobs )
475
476      !!----------------------------------------------------------------------
477      !!                     ***  ROUTINE obs_prof_alloc_var  ***
478      !!                     
479      !! ** Purpose : - Allocate data for variable data in profile arrays
480      !!
481      !! ** Method  : - Fortran-90 dynamic arrays
482      !!
483      !! History :
484      !!        !  07-03  (K. Mogensen) Original code
485      !! * Arguments
486      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be allocated
487      INTEGER, INTENT(IN) :: kvar   ! Variable number
488      INTEGER, INTENT(IN) :: kext   ! Number of extra fields within each variable
489      INTEGER, INTENT(IN) :: kobs   ! Number of observations
490     
491      ALLOCATE( & 
492         & prof%var(kvar)%mvk(kobs),       &
493         & prof%var(kvar)%nvpidx(kobs),    &
494         & prof%var(kvar)%nvlidx(kobs),    &
495         & prof%var(kvar)%nvqc(kobs),      &
496         & prof%var(kvar)%idqc(kobs),      &
497         & prof%var(kvar)%vdep(kobs),      &
498         & prof%var(kvar)%vobs(kobs),      &
499         & prof%var(kvar)%vmod(kobs),      &
500         & prof%var(kvar)%nvind(kobs)      &
501         & )
502      ALLOCATE( & 
503         & prof%var(kvar)%idqcf(idefnqcf,kobs), &
504         & prof%var(kvar)%nvqcf(idefnqcf,kobs)  &
505         & )
506      IF (kext>0) THEN
507         ALLOCATE( & 
508            & prof%var(kvar)%vext(kobs,kext) &
509            & )
510      ENDIF
511      IF (prof%lclim) THEN
512         ALLOCATE( & 
513            & prof%var(kvar)%vclm(kobs) &
514            & )
515      ENDIF
516
517   END SUBROUTINE obs_prof_alloc_var
518
519   SUBROUTINE obs_prof_dealloc_var( prof, kvar )
520
521      !!----------------------------------------------------------------------
522      !!                     ***  ROUTINE obs_prof_alloc_var  ***
523      !!                     
524      !! ** Purpose : - Allocate data for variable data in profile arrays
525      !!
526      !! ** Method  : - Fortran-90 dynamic arrays
527      !!
528      !! History :
529      !!        !  07-03  (K. Mogensen) Original code
530      !! * Arguments
531      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be allocated
532      INTEGER, INTENT(IN) :: kvar      ! Variable number
533     
534      DEALLOCATE( & 
535         & prof%var(kvar)%mvk,    &
536         & prof%var(kvar)%nvpidx, &
537         & prof%var(kvar)%nvlidx, &
538         & prof%var(kvar)%nvqc,   &
539         & prof%var(kvar)%idqc,   &
540         & prof%var(kvar)%vdep,   &
541         & prof%var(kvar)%vobs,   &
542         & prof%var(kvar)%vmod,   &
543         & prof%var(kvar)%nvind,  &
544         & prof%var(kvar)%idqcf,  &
545         & prof%var(kvar)%nvqcf   &
546         & )
547      IF (prof%next>0) THEN
548         DEALLOCATE( & 
549            & prof%var(kvar)%vext  &
550            & )
551      ENDIF
552      IF (prof%lclim) THEN
553         DEALLOCATE( & 
554            & prof%var(kvar)%vclm  &
555            & )
556      ENDIF
557
558   END SUBROUTINE obs_prof_dealloc_var
559
560   SUBROUTINE obs_prof_compress( prof,   newprof, lallocate, &
561      &                          kumout, lvalid,   lvvalid )
562      !!----------------------------------------------------------------------
563      !!                     ***  ROUTINE obs_prof_compress  ***
564      !!                     
565      !! ** Purpose : - Extract sub-information from a obs_prof type
566      !!                into a new obs_prof type
567      !!
568      !! ** Method  : - The data is copied from prof to new prof.
569      !!                In the case of lvalid and lvvalid both being
570      !!                present only the selected data will be copied.
571      !!                If lallocate is true the data in the newprof is
572      !!                allocated either with the same number of elements
573      !!                as prof or with only the subset of elements defined
574      !!                by the optional selection in lvalid and lvvalid
575      !!
576      !! History :
577      !!        !  07-01  (K. Mogensen) Original code
578      !!----------------------------------------------------------------------
579      !! * Arguments
580      TYPE(obs_prof), INTENT(IN)    :: prof      ! Original profile
581      TYPE(obs_prof), INTENT(INOUT) :: newprof   ! New profile with the copy of the data
582      LOGICAL :: lallocate                ! Allocate newprof data
583      INTEGER,INTENT(IN) :: kumout        ! Fortran unit for messages
584      TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: &
585         & lvalid        ! Valid profiles
586      TYPE(obs_prof_valid), OPTIONAL, INTENT(in), DIMENSION(prof%nvar) :: &
587         & lvvalid       ! Valid data within the profiles
588     
589      !!* Local variables
590      INTEGER :: inprof
591      INTEGER, DIMENSION(prof%nvar) :: &
592         & invpro
593      INTEGER :: jvar
594      INTEGER :: jext
595      INTEGER :: ji
596      INTEGER :: jj 
597      LOGICAL :: lfirst
598      TYPE(obs_prof_valid) :: &
599         & llvalid
600      TYPE(obs_prof_valid), DIMENSION(prof%nvar) :: &
601         & llvvalid
602      LOGICAL :: lallpresent
603      LOGICAL :: lnonepresent
604
605      ! Check that either all or none of the masks are persent.
606
607      lallpresent  = .FALSE.
608      lnonepresent = .FALSE.
609      IF ( PRESENT(lvalid) .AND. PRESENT(lvvalid) ) THEN
610         lallpresent =  .TRUE.
611      ELSEIF ( ( .NOT. PRESENT(lvalid)  ) .AND. &
612         &     ( .NOT. PRESENT(lvvalid) ) ) THEN
613         lnonepresent = .TRUE.
614      ELSE
615         CALL ctl_stop('Error in obs_prof_compress:', &
616            &          'Either all selection variables should be set', &
617            &          'or no selection variable should be set' )
618      ENDIF
619     
620      ! Count how many elements there should be in the new data structure
621
622      IF ( lallpresent ) THEN
623         inprof = 0
624         invpro(:) = 0
625         DO ji = 1, prof%nprof
626            IF ( lvalid%luse(ji) ) THEN
627               inprof=inprof+1
628               DO jvar = 1, prof%nvar
629                  DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
630                     IF ( lvvalid(jvar)%luse(jj) ) &
631                        &           invpro(jvar) = invpro(jvar) +1
632                  END DO
633               END DO
634            ENDIF
635         END DO
636      ELSE
637         inprof    = prof%nprof
638         invpro(:) = prof%nvprot(:)
639      ENDIF
640
641      ! Optionally allocate data in the new data structure
642
643      IF ( lallocate ) THEN
644         CALL obs_prof_alloc( newprof,   prof%nvar, &
645            &                 prof%next,            &
646            &                 inprof,    invpro,    &
647            &                 prof%nstp, prof%npi,  &
648            &                 prof%npj,  prof%npk,  &
649            &                 prof%lclim )
650      ENDIF
651
652      ! Allocate temporary mask array to unify the code for both cases
653
654      ALLOCATE( llvalid%luse(prof%nprof) )
655      DO jvar = 1, prof%nvar
656         ALLOCATE( llvvalid(jvar)%luse(prof%nvprot(jvar)) )
657      END DO
658      IF ( lallpresent ) THEN
659         llvalid%luse(:) = lvalid%luse(:)
660         DO jvar = 1, prof%nvar
661            llvvalid(jvar)%luse(:) = lvvalid(jvar)%luse(:)
662         END DO
663      ELSE
664         llvalid%luse(:) = .TRUE.
665         DO jvar = 1, prof%nvar
666            llvvalid(jvar)%luse(:) = .TRUE.
667         END DO
668      ENDIF
669
670      ! Setup bookkeeping variables
671
672      inprof    = 0
673      invpro(:) = 0
674
675      newprof%npvsta(:,:) =  0
676      newprof%npvend(:,:) = -1
677     
678      ! Loop over source profiles
679
680      DO ji = 1, prof%nprof
681
682         IF ( llvalid%luse(ji) ) THEN
683
684            ! Copy the header information
685
686            inprof = inprof + 1
687
688            newprof%mi(inprof,:)  = prof%mi(ji,:)
689            newprof%mj(inprof,:) = prof%mj(ji,:)
690            newprof%npidx(inprof) = prof%npidx(ji)
691            newprof%npfil(inprof) = prof%npfil(ji)
692            newprof%nyea(inprof)  = prof%nyea(ji)
693            newprof%nmon(inprof)  = prof%nmon(ji)
694            newprof%nday(inprof)  = prof%nday(ji)
695            newprof%nhou(inprof)  = prof%nhou(ji)
696            newprof%nmin(inprof)  = prof%nmin(ji)
697            newprof%mstp(inprof)  = prof%mstp(ji)
698            newprof%nqc(inprof)   = prof%nqc(ji)
699            newprof%ipqc(inprof)  = prof%ipqc(ji)
700            newprof%itqc(inprof)  = prof%itqc(ji)
701            newprof%ivqc(inprof,:)= prof%ivqc(ji,:)
702            newprof%ntyp(inprof)  = prof%ntyp(ji)
703            newprof%rlam(inprof)  = prof%rlam(ji)
704            newprof%rphi(inprof)  = prof%rphi(ji)
705            newprof%cwmo(inprof)  = prof%cwmo(ji)
706           
707            ! QC info
708
709            newprof%nqcf(:,inprof)    = prof%nqcf(:,ji)
710            newprof%ipqcf(:,inprof)   = prof%ipqcf(:,ji)
711            newprof%itqcf(:,inprof)   = prof%itqcf(:,ji)
712            newprof%ivqcf(:,inprof,:) = prof%ivqcf(:,ji,:)
713           
714            ! npind is the index of the original profile
715           
716            newprof%npind(inprof) = ji
717
718            ! Copy the variable information
719
720            DO jvar = 1, prof%nvar
721
722               lfirst = .TRUE.
723               
724               DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
725                 
726                  IF ( llvvalid(jvar)%luse(jj) ) THEN
727
728                     invpro(jvar) = invpro(jvar) + 1
729                 
730                     ! Book keeping information
731                                   
732                     IF ( lfirst ) THEN
733                        lfirst = .FALSE.
734                        newprof%npvsta(inprof,jvar) = invpro(jvar)
735                     ENDIF
736                     newprof%npvend(inprof,jvar) = invpro(jvar)
737
738                     ! Variable data
739                     
740                     newprof%var(jvar)%mvk(invpro(jvar))    = &
741                        &                           prof%var(jvar)%mvk(jj)
742                     newprof%var(jvar)%nvpidx(invpro(jvar)) = &
743                        &                           prof%var(jvar)%nvpidx(jj)
744                     newprof%var(jvar)%nvlidx(invpro(jvar)) = &
745                        &                           prof%var(jvar)%nvlidx(jj)
746                     newprof%var(jvar)%nvqc(invpro(jvar))   = &
747                        &                           prof%var(jvar)%nvqc(jj)
748                     newprof%var(jvar)%idqc(invpro(jvar))   = &
749                        &                           prof%var(jvar)%idqc(jj)
750                     newprof%var(jvar)%idqcf(:,invpro(jvar))= &
751                        &                           prof%var(jvar)%idqcf(:,jj)
752                     newprof%var(jvar)%nvqcf(:,invpro(jvar))= &
753                        &                           prof%var(jvar)%nvqcf(:,jj)
754                     newprof%var(jvar)%vdep(invpro(jvar))   = &
755                        &                           prof%var(jvar)%vdep(jj)
756                     newprof%var(jvar)%vobs(invpro(jvar))   = &
757                        &                           prof%var(jvar)%vobs(jj)
758                     newprof%var(jvar)%vmod(invpro(jvar))   = &
759                        &                           prof%var(jvar)%vmod(jj)
760                     DO jext = 1, prof%next
761                        newprof%var(jvar)%vext(invpro(jvar),jext) = &
762                           &                      prof%var(jvar)%vext(jj,jext)
763                     END DO
764                     IF (newprof%lclim) THEN
765                        newprof%var(jvar)%vclm(invpro(jvar))   = &
766                           &                           prof%var(jvar)%vclm(jj)
767                     ENDIF
768                                   
769                     ! nvind is the index of the original variable data
770                     
771                     newprof%var(jvar)%nvind(invpro(jvar))  = jj
772                     
773                  ENDIF
774
775               END DO
776
777            END DO
778
779         ENDIF
780
781      END DO
782
783      ! Update MPP counters
784
785      DO jvar = 1, prof%nvar
786         newprof%nvprot(jvar) = invpro(jvar)
787      END DO
788      CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,&
789         &                        prof%nvar )
790     
791      ! Set book keeping variables which do not depend on number of obs.
792
793      newprof%nvar     = prof%nvar
794      newprof%next     = prof%next
795      newprof%nstp     = prof%nstp
796      newprof%npi      = prof%npi
797      newprof%npj      = prof%npj
798      newprof%npk      = prof%npk
799      newprof%cvars(:) = prof%cvars(:)
800 
801      ! Deallocate temporary data
802
803      DO jvar = 1, prof%nvar
804         DEALLOCATE( llvvalid(jvar)%luse )
805      END DO
806 
807      DEALLOCATE( llvalid%luse )
808     
809   END SUBROUTINE obs_prof_compress
810
811   SUBROUTINE obs_prof_decompress( prof, oldprof, ldeallocate, kumout )
812      !!----------------------------------------------------------------------
813      !!                     ***  ROUTINE obs_prof_decompress  ***
814      !!                     
815      !! ** Purpose : - Copy back information to original profile type
816      !!
817      !! ** Method  : - Reinsert updated information from a previous
818      !!                copied/compressed profile type into the original
819      !!                profile data and optionally deallocate the prof
820      !!                data input
821      !!
822      !! History :
823      !!        !  07-01  (K. Mogensen) Original code
824      !!----------------------------------------------------------------------
825      !! * Arguments
826      TYPE(obs_prof),INTENT(INOUT) :: prof      ! Updated profile data
827      TYPE(obs_prof),INTENT(INOUT) :: oldprof   ! Original profile data
828      LOGICAL :: ldeallocate         ! Deallocate the updated data of insertion
829      INTEGER,INTENT(in) :: kumout   ! Output unit
830     
831      !!* Local variables
832      INTEGER :: jvar
833      INTEGER :: jext
834      INTEGER :: ji
835      INTEGER :: jj
836      INTEGER :: jk
837      INTEGER :: jl
838
839      DO ji = 1, prof%nprof
840
841         ! Copy header information
842         
843         jk = prof%npind(ji)
844     
845         oldprof%mi(jk,:)  = prof%mi(ji,:)
846         oldprof%mj(jk,:)  = prof%mj(ji,:)
847         oldprof%npidx(jk) = prof%npidx(ji)
848         oldprof%npfil(jk) = prof%npfil(ji)
849         oldprof%nyea(jk)  = prof%nyea(ji)
850         oldprof%nmon(jk)  = prof%nmon(ji)
851         oldprof%nday(jk)  = prof%nday(ji)
852         oldprof%nhou(jk)  = prof%nhou(ji)
853         oldprof%nmin(jk)  = prof%nmin(ji)
854         oldprof%mstp(jk)  = prof%mstp(ji)
855         oldprof%nqc(jk)   = prof%nqc(ji)
856         oldprof%ipqc(jk)  = prof%ipqc(ji)
857         oldprof%itqc(jk)  = prof%itqc(ji)
858         oldprof%ivqc(jk,:)= prof%ivqc(ji,:)
859         oldprof%ntyp(jk)  = prof%ntyp(ji)
860         oldprof%rlam(jk)  = prof%rlam(ji)
861         oldprof%rphi(jk)  = prof%rphi(ji)
862         oldprof%cwmo(jk)  = prof%cwmo(ji)
863         
864         ! QC info
865
866         oldprof%nqcf(:,jk)    = prof%nqcf(:,ji)
867         oldprof%ipqcf(:,jk)   = prof%ipqcf(:,ji)
868         oldprof%itqcf(:,jk)   = prof%itqcf(:,ji)
869         oldprof%ivqcf(:,jk,:) = prof%ivqcf(:,ji,:)
870
871         ! Copy the variable information
872
873         DO jvar = 1, prof%nvar
874
875            DO jj = prof%npvsta(ji,jvar), prof%npvend(ji,jvar)
876               
877               jl = prof%var(jvar)%nvind(jj)
878
879               oldprof%var(jvar)%mvk(jl)    = prof%var(jvar)%mvk(jj)
880               oldprof%var(jvar)%nvpidx(jl) = prof%var(jvar)%nvpidx(jj)
881               oldprof%var(jvar)%nvlidx(jl) = prof%var(jvar)%nvlidx(jj)
882               oldprof%var(jvar)%nvqc(jl)   = prof%var(jvar)%nvqc(jj)
883               oldprof%var(jvar)%idqc(jl)   = prof%var(jvar)%idqc(jj)
884               oldprof%var(jvar)%vdep(jl)   = prof%var(jvar)%vdep(jj)
885               oldprof%var(jvar)%vobs(jl)   = prof%var(jvar)%vobs(jj)
886               oldprof%var(jvar)%vmod(jl)   = prof%var(jvar)%vmod(jj)
887               oldprof%var(jvar)%idqcf(:,jl) = prof%var(jvar)%idqcf(:,jj)
888               oldprof%var(jvar)%nvqcf(:,jl) = prof%var(jvar)%nvqcf(:,jj)
889               DO jext = 1, prof%next
890                  oldprof%var(jvar)%vext(jl,jext) = &
891                     &                        prof%var(jvar)%vext(jj,jext)
892               END DO
893               IF (prof%lclim) THEN
894                  oldprof%var(jvar)%vclm(jl)   = prof%var(jvar)%vclm(jj)
895               ENDIF             
896            END DO
897
898         END DO
899         
900      END DO
901
902      ! Optionally deallocate the updated profile data
903
904      IF ( ldeallocate ) CALL obs_prof_dealloc( prof )
905     
906   END SUBROUTINE obs_prof_decompress
907
908   SUBROUTINE obs_prof_staend( prof, kvarno )
909      !!----------------------------------------------------------------------
910      !!                     ***  ROUTINE obs_prof_decompress  ***
911      !!                     
912      !! ** Purpose : - Set npvsta and npvend of a variable within
913      !!                an obs_prof_var type
914      !!
915      !! ** Method  : - Find the start and stop of a profile by searching
916      !!                through the data
917      !!
918      !! History :
919      !!        !  07-04  (K. Mogensen) Original code
920      !!----------------------------------------------------------------------
921      !! * Arguments
922      TYPE(obs_prof),INTENT(INOUT) :: prof     ! Profile data
923      INTEGER,INTENT(IN) :: kvarno     ! Variable number
924
925      !!* Local variables
926      INTEGER :: ji
927      INTEGER :: iprofno
928
929      !-----------------------------------------------------------------------
930      ! Compute start and end bookkeeping arrays
931      !-----------------------------------------------------------------------
932
933      prof%npvsta(:,kvarno) = prof%nvprot(kvarno) + 1
934      prof%npvend(:,kvarno) = -1
935      DO ji = 1, prof%nvprot(kvarno)
936         iprofno = prof%var(kvarno)%nvpidx(ji)
937         prof%npvsta(iprofno,kvarno) = &
938            & MIN( ji, prof%npvsta(iprofno,kvarno) )
939         prof%npvend(iprofno,kvarno) = &
940            & MAX( ji, prof%npvend(iprofno,kvarno) )
941      END DO
942
943      DO ji = 1, prof%nprof
944         IF ( prof%npvsta(ji,kvarno) == ( prof%nvprot(kvarno) + 1 ) ) &
945            & prof%npvsta(ji,kvarno) = 0
946      END DO
947
948   END SUBROUTINE obs_prof_staend
949   
950END MODULE obs_profiles_def
951
Note: See TracBrowser for help on using the repository browser.