source: branches/UKMO/r6232_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_profiles_def.F90 @ 11202

Last change on this file since 11202 was 11202, checked in by jcastill, 15 months ago

Copy of branch branches/UKMO/dev_r5518_obs_oper_update@11130 without namelist_ref changes to allow merging with coupling and biogeochemistry branches

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