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

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90 @ 2281

Last change on this file since 2281 was 2281, checked in by smasson, 14 years ago

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