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.
Changeset 9205 for branches/UKMO/dev_r5518_obs_oper_update_bgc3d/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90 – NEMO

Ignore:
Timestamp:
2018-01-10T15:50:38+01:00 (6 years ago)
Author:
dford
Message:

Change obs_pre_prof to loop over an arbitrary number of variables.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5518_obs_oper_update_bgc3d/NEMOGCM/NEMO/OPA_SRC/OBS/obs_prep.F90

    r9186 r9205  
    255255 
    256256 
    257    SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, & 
     257   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 
    258258      &                     kpi, kpj, kpk, & 
    259       &                     zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2,  & 
     259      &                     zmask, pglam, pgphi,  & 
    260260      &                     ld_nea, ld_bound_reject, kdailyavtypes,  kqc_cutoff ) 
    261261 
    … …  
    284284      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    285285      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening 
    286       LOGICAL, INTENT(IN) :: ld_var1              ! Observed variables switches 
    287       LOGICAL, INTENT(IN) :: ld_var2 
     286      LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 
     287         & ld_var                                 ! Observed variables switches 
    288288      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land 
    289289      LOGICAL, INTENT(IN) :: ld_bound_reject      ! Switch for rejecting observations near the boundary 
    … …  
    291291      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    292292         & kdailyavtypes                          ! Types for daily averages 
    293       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    294          & zmask1, & 
    295          & zmask2 
    296       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    297          & pglam1, & 
    298          & pglam2, & 
    299          & pgphi1, & 
    300          & pgphi2 
     293      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 
     294         & zmask 
     295      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 
     296         & pglam, & 
     297         & pgphi 
    301298      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value 
    302299 
    … …  
    309306      INTEGER :: imin0 
    310307      INTEGER :: icycle       ! Current assimilation cycle 
    311                               ! Counters for observations that are 
    312       INTEGER :: iotdobs      !  - outside time domain 
    313       INTEGER :: iosdv1obs    !  - outside space domain (variable 1) 
    314       INTEGER :: iosdv2obs    !  - outside space domain (variable 2) 
    315       INTEGER :: ilanv1obs    !  - within a model land cell (variable 1) 
    316       INTEGER :: ilanv2obs    !  - within a model land cell (variable 2) 
    317       INTEGER :: inlav1obs    !  - close to land (variable 1) 
    318       INTEGER :: inlav2obs    !  - close to land (variable 2) 
    319       INTEGER :: ibdyv1obs    !  - boundary (variable 1)  
    320       INTEGER :: ibdyv2obs    !  - boundary (variable 2)       
    321       INTEGER :: igrdobs      !  - fail the grid search 
    322       INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    323       INTEGER :: iuvchkv      ! 
    324                               ! Global counters for observations that are 
    325       INTEGER :: iotdobsmpp   !  - outside time domain 
    326       INTEGER :: iosdv1obsmpp !  - outside space domain (variable 1) 
    327       INTEGER :: iosdv2obsmpp !  - outside space domain (variable 2) 
    328       INTEGER :: ilanv1obsmpp !  - within a model land cell (variable 1) 
    329       INTEGER :: ilanv2obsmpp !  - within a model land cell (variable 2) 
    330       INTEGER :: inlav1obsmpp !  - close to land (variable 1) 
    331       INTEGER :: inlav2obsmpp !  - close to land (variable 2) 
    332       INTEGER :: ibdyv1obsmpp !  - boundary (variable 1)  
    333       INTEGER :: ibdyv2obsmpp !  - boundary (variable 2)       
    334       INTEGER :: igrdobsmpp   !  - fail the grid search 
    335       INTEGER :: iuvchkumpp   !  - reject var1 if var2 rejected and vice versa 
    336       INTEGER :: iuvchkvmpp   ! 
     308                                                       ! Counters for observations that are 
     309      INTEGER                           :: iotdobs     !  - outside time domain 
     310      INTEGER, DIMENSION(profdata%nvar) :: iosdvobs    !  - outside space domain 
     311      INTEGER, DIMENSION(profdata%nvar) :: ilanvobs    !  - within a model land cell 
     312      INTEGER, DIMENSION(profdata%nvar) :: inlavobs    !  - close to land 
     313      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs    !  - boundary    
     314      INTEGER                           :: igrdobs     !  - fail the grid search 
     315      INTEGER                           :: iuvchku     !  - reject UVEL if VVEL rejected 
     316      INTEGER                           :: iuvchkv     !  - reject VVEL if UVEL rejected 
     317                                                       ! Global counters for observations that are 
     318      INTEGER                           :: iotdobsmpp  !  - outside time domain 
     319      INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp !  - outside space domain 
     320      INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp !  - within a model land cell 
     321      INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp !  - close to land 
     322      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp !  - boundary 
     323      INTEGER :: igrdobsmpp                            !  - fail the grid search 
     324      INTEGER :: iuvchkumpp                            !  - reject UVEL if VVEL rejected 
     325      INTEGER :: iuvchkvmpp                            !  - reject VVEL if UVEL rejected 
    337326      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
    338327      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    339          & llvvalid           ! var1,var2 selection  
     328         & llvvalid           ! vars selection  
    340329      INTEGER :: jvar         ! Variable loop variable 
    341330      INTEGER :: jobs         ! Obs. loop variable 
    342331      INTEGER :: jstp         ! Time loop variable 
    343332      INTEGER :: inrc         ! Time index variable 
     333      CHARACTER(LEN=256) :: cout1  ! Diagnostic output line 
     334      CHARACTER(LEN=256) :: cout2  ! Diagnostic output line 
    344335 
    345336      IF(lwp) WRITE(numout,*)'obs_pre_prof: Preparing the profile data...' 
    … …  
    355346      icycle = no     ! Assimilation cycle 
    356347 
    357       ! Diagnotics counters for various failures. 
    358  
    359       iotdobs   = 0 
    360       igrdobs   = 0 
    361       iosdv1obs = 0 
    362       iosdv2obs = 0 
    363       ilanv1obs = 0 
    364       ilanv2obs = 0 
    365       inlav1obs = 0 
    366       inlav2obs = 0 
    367       ibdyv1obs = 0 
    368       ibdyv2obs = 0 
    369       iuvchku   = 0 
    370       iuvchkv   = 0 
     348      ! Diagnostics counters for various failures. 
     349 
     350      iotdobs     = 0 
     351      igrdobs     = 0 
     352      iosdvobs(:) = 0 
     353      ilanvobs(:) = 0 
     354      inlavobs(:) = 0 
     355      ibdyvobs(:) = 0 
     356      iuvchku     = 0 
     357      iuvchkv     = 0 
    371358 
    372359 
    … …  
    401388      ! ----------------------------------------------------------------------- 
    402389 
    403       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,1), profdata%mj(:,1), & 
    404          &              profdata%nqc,     igrdobs                         ) 
    405       IF ( ld_var2 ) THEN 
    406          CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,2), profdata%mj(:,2), & 
    407             &              profdata%nqc,     igrdobs                         ) 
    408       ENDIF 
     390      DO jvar = 1, profdata%nvar 
     391         CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,jvar), profdata%mj(:,jvar), & 
     392            &              profdata%nqc,     igrdobs ) 
     393      END DO 
    409394 
    410395      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    … …  
    421406      ! ----------------------------------------------------------------------- 
    422407 
    423       ! Variable 1 
    424       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    425          &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    426          &                 jpi,                   jpj,                  & 
    427          &                 jpk,                                         & 
    428          &                 profdata%mi,           profdata%mj,          & 
    429          &                 profdata%var(1)%mvk,                         & 
    430          &                 profdata%rlam,         profdata%rphi,        & 
    431          &                 profdata%var(1)%vdep,                        & 
    432          &                 pglam1,                pgphi1,               & 
    433          &                 gdept_1d,              zmask1,               & 
    434          &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    435          &                 iosdv1obs,             ilanv1obs,            & 
    436          &                 inlav1obs,             ld_nea,               & 
    437          &                 ibdyv1obs,             ld_bound_reject,      & 
    438          &                 iqc_cutoff       ) 
    439  
    440       CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 
    441       CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 
    442       CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 
    443       CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 
    444  
    445       IF ( ld_var2 ) THEN 
    446          ! Variable 2 
    447          CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    448             &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    449             &                 jpi,                   jpj,                  & 
    450             &                 jpk,                                         & 
    451             &                 profdata%mi,           profdata%mj,          &  
    452             &                 profdata%var(2)%mvk,                         & 
    453             &                 profdata%rlam,         profdata%rphi,        & 
    454             &                 profdata%var(2)%vdep,                        & 
    455             &                 pglam2,                pgphi2,               & 
    456             &                 gdept_1d,              zmask2,               & 
    457             &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    458             &                 iosdv2obs,             ilanv2obs,            & 
    459             &                 inlav2obs,             ld_nea,               & 
    460             &                 ibdyv2obs,             ld_bound_reject,      & 
     408      DO jvar = 1, profdata%nvar 
     409         CALL obs_coo_spc_3d( profdata%nprof,          profdata%nvprot(jvar),   & 
     410            &                 profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 
     411            &                 jpi,                     jpj,                     & 
     412            &                 jpk,                                              & 
     413            &                 profdata%mi,             profdata%mj,             & 
     414            &                 profdata%var(jvar)%mvk,                           & 
     415            &                 profdata%rlam,           profdata%rphi,           & 
     416            &                 profdata%var(jvar)%vdep,                          & 
     417            &                 pglam(:,:,jvar),         pgphi(:,:,jvar),         & 
     418            &                 gdept_1d,                zmask(:,:,:,jvar),       & 
     419            &                 profdata%nqc,            profdata%var(jvar)%nvqc, & 
     420            &                 iosdvobs(jvar),          ilanvobs(jvar),          & 
     421            &                 inlavobs(jvar),          ld_nea,                  & 
     422            &                 ibdyvobs(jvar),          ld_bound_reject,         & 
    461423            &                 iqc_cutoff       ) 
    462424 
    463          CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 
    464          CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 
    465          CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 
    466          CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 
    467       ENDIF 
     425         CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 
     426         CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 
     427         CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 
     428         CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 
     429      END DO 
    468430 
    469431      ! ----------------------------------------------------------------------- 
    … …  
    516478       
    517479         WRITE(numout,*) 
    518          WRITE(numout,*) ' Profiles outside time domain                     = ', & 
     480         WRITE(numout,*) ' Profiles outside time domain                       = ', & 
    519481            &            iotdobsmpp 
    520          WRITE(numout,*) ' Remaining profiles that failed grid search       = ', & 
     482         WRITE(numout,*) ' Remaining profiles that failed grid search         = ', & 
    521483            &            igrdobsmpp 
    522          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain       = ', & 
    523             &            iosdv1obsmpp 
    524          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points             = ', & 
    525             &            ilanv1obsmpp 
    526          IF (ld_nea) THEN 
    527             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 
    528                &            inlav1obsmpp 
    529          ELSE 
    530             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept)    = ',& 
    531                &            inlav1obsmpp 
    532          ENDIF 
    533          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    534             WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
    535                &            iuvchku 
    536          ENDIF 
    537          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 
    538                &            ibdyv1obsmpp 
    539          WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted                             = ', & 
    540             &            prodatqc%nvprotmpp(1) 
    541          IF ( ld_var2 ) THEN 
    542             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain       = ', & 
    543                &            iosdv2obsmpp 
    544             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points             = ', & 
    545                &            ilanv2obsmpp 
     484         DO jvar = 1, profdata%nvar 
     485            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain       = ', & 
     486               &            iosdvobsmpp(jvar) 
     487            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points             = ', & 
     488               &            ilanvobsmpp(jvar) 
    546489            IF (ld_nea) THEN 
    547                WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 
    548                   &            inlav2obsmpp 
     490               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 
     491                  &            inlavobsmpp(jvar) 
    549492            ELSE 
    550                WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept)    = ',& 
    551                   &            inlav2obsmpp 
    552             ENDIF 
    553             IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
     493               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept)    = ',& 
     494                  &            inlavobsmpp(jvar) 
     495            ENDIF 
     496            IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 
     497               WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
     498                  &            iuvchku 
     499            ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 
    554500               WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
    555501                  &            iuvchkv 
    556502            ENDIF 
    557             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 
    558                   &            ibdyv2obsmpp 
    559             WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted                             = ', & 
    560                &            prodatqc%nvprotmpp(2) 
    561          ENDIF 
     503            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 
     504                  &            ibdyvobsmpp(jvar) 
     505            WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted                             = ', & 
     506               &            prodatqc%nvprotmpp(jvar) 
     507         END DO 
    562508 
    563509         WRITE(numout,*) 
    564510         WRITE(numout,*) ' Number of observations per time step :' 
    565511         WRITE(numout,*) 
    566          IF ( ld_var2 ) THEN 
    567             WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 
    568                &                               '   '//prodatqc%cvars(1)//'     ', & 
    569                &                               '   '//prodatqc%cvars(2)//'     ' 
    570          ELSE 
    571             WRITE(numout,'(10X,A,5X,A,5X,A)')'Time step','Profiles', & 
    572                &                               '   '//prodatqc%cvars(1)//'     ' 
    573          ENDIF 
    574          WRITE(numout,998) 
     512         WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 
     513         WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 
     514         DO jvar = 1, prodatqc%nvar 
     515            WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 
     516            WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 
     517         END DO 
     518         WRITE(numout,*) cout1 
     519         WRITE(numout,*) cout2 
    575520      ENDIF 
    576521       
    … …  
    599544         DO jstp = nit000 - 1, nitend 
    600545            inrc = jstp - nit000 + 2 
    601             IF ( ld_var2 ) THEN 
    602                WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    603                   &                    prodatqc%nvstpmpp(inrc,1), & 
    604                   &                    prodatqc%nvstpmpp(inrc,2) 
    605             ELSE 
    606                WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    607                   &                    prodatqc%nvstpmpp(inrc,1) 
    608             ENDIF 
     546            WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 
     547            DO jvar = 1, prodatqc%nvar 
     548               WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 
     549            END DO 
     550            WRITE(numout,*) cout1 
    609551         END DO 
    610552      ENDIF 
    611  
    612 998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 
    613 999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    614553 
    615554   END SUBROUTINE obs_pre_prof 
Note: See TracChangeset for help on using the changeset viewer.