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_addclim/NEMOGCM/NEMO/OPA_SRC/OBS – NEMO

source: branches/UKMO/dev_r5518_obs_oper_update_addclim/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90 @ 11449

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

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