source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90 @ 9295

Last change on this file since 9295 was 9295, checked in by jcastill, 3 years ago

Remove svn keywords

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