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 14056 for NEMO/trunk/src/OCE/OBS/obs_prep.F90 – NEMO

Ignore:
Timestamp:
2020-12-03T15:08:29+01:00 (3 years ago)
Author:
ayoung
Message:

Adding branch for ticket #2567 to trunk.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • NEMO/trunk/src/OCE/OBS/obs_prep.F90

    r12489 r14056  
    241241 
    242242 
    243    SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var1, ld_var2, & 
     243   SUBROUTINE obs_pre_prof( profdata, prodatqc, ld_var, & 
    244244      &                     kpi, kpj, kpk, & 
    245       &                     zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2,  & 
     245      &                     zmask, pglam, pgphi,  & 
    246246      &                     ld_nea, ld_bound_reject, Kmm, kdailyavtypes,  kqc_cutoff ) 
    247247 
    … …  
    269269      TYPE(obs_prof), INTENT(INOUT) :: profdata   ! Full set of profile data 
    270270      TYPE(obs_prof), INTENT(INOUT) :: prodatqc   ! Subset of profile data not failing screening 
    271       LOGICAL, INTENT(IN) :: ld_var1              ! Observed variables switches 
    272       LOGICAL, INTENT(IN) :: ld_var2 
     271      LOGICAL, DIMENSION(profdata%nvar), INTENT(IN) :: & 
     272         & ld_var                                 ! Observed variables switches 
    273273      LOGICAL, INTENT(IN) :: ld_nea               ! Switch for rejecting observation near land 
    274274      LOGICAL, INTENT(IN) :: ld_bound_reject      ! Switch for rejecting observations near the boundary 
    … …  
    277277      INTEGER, DIMENSION(imaxavtypes), OPTIONAL :: & 
    278278         & kdailyavtypes                          ! Types for daily averages 
    279       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & 
    280          & zmask1, & 
    281          & zmask2 
    282       REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & 
    283          & pglam1, & 
    284          & pglam2, & 
    285          & pgphi1, & 
    286          & pgphi2 
     279      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk,profdata%nvar) :: & 
     280         & zmask 
     281      REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,profdata%nvar) :: & 
     282         & pglam, & 
     283         & pgphi 
    287284      INTEGER, INTENT(IN), OPTIONAL :: kqc_cutoff   ! cut off for QC value 
    288285 
    … …  
    295292      INTEGER :: imin0 
    296293      INTEGER :: icycle       ! Current assimilation cycle 
    297                               ! Counters for observations that are 
    298       INTEGER :: iotdobs      !  - outside time domain 
    299       INTEGER :: iosdv1obs    !  - outside space domain (variable 1) 
    300       INTEGER :: iosdv2obs    !  - outside space domain (variable 2) 
    301       INTEGER :: ilanv1obs    !  - within a model land cell (variable 1) 
    302       INTEGER :: ilanv2obs    !  - within a model land cell (variable 2) 
    303       INTEGER :: inlav1obs    !  - close to land (variable 1) 
    304       INTEGER :: inlav2obs    !  - close to land (variable 2) 
    305       INTEGER :: ibdyv1obs    !  - boundary (variable 1)  
    306       INTEGER :: ibdyv2obs    !  - boundary (variable 2)       
    307       INTEGER :: igrdobs      !  - fail the grid search 
    308       INTEGER :: iuvchku      !  - reject u if v rejected and vice versa 
    309       INTEGER :: iuvchkv      ! 
    310                               ! Global counters for observations that are 
    311       INTEGER :: iotdobsmpp   !  - outside time domain 
    312       INTEGER :: iosdv1obsmpp !  - outside space domain (variable 1) 
    313       INTEGER :: iosdv2obsmpp !  - outside space domain (variable 2) 
    314       INTEGER :: ilanv1obsmpp !  - within a model land cell (variable 1) 
    315       INTEGER :: ilanv2obsmpp !  - within a model land cell (variable 2) 
    316       INTEGER :: inlav1obsmpp !  - close to land (variable 1) 
    317       INTEGER :: inlav2obsmpp !  - close to land (variable 2) 
    318       INTEGER :: ibdyv1obsmpp !  - boundary (variable 1)  
    319       INTEGER :: ibdyv2obsmpp !  - boundary (variable 2)       
    320       INTEGER :: igrdobsmpp   !  - fail the grid search 
    321       INTEGER :: iuvchkumpp   !  - reject var1 if var2 rejected and vice versa 
    322       INTEGER :: iuvchkvmpp   ! 
     294                                                       ! Counters for observations that are 
     295      INTEGER                           :: iotdobs     !  - outside time domain 
     296      INTEGER, DIMENSION(profdata%nvar) :: iosdvobs    !  - outside space domain 
     297      INTEGER, DIMENSION(profdata%nvar) :: ilanvobs    !  - within a model land cell 
     298      INTEGER, DIMENSION(profdata%nvar) :: inlavobs    !  - close to land 
     299      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobs    !  - boundary    
     300      INTEGER                           :: igrdobs     !  - fail the grid search 
     301      INTEGER                           :: iuvchku     !  - reject UVEL if VVEL rejected 
     302      INTEGER                           :: iuvchkv     !  - reject VVEL if UVEL rejected 
     303                                                       ! Global counters for observations that are 
     304      INTEGER                           :: iotdobsmpp  !  - outside time domain 
     305      INTEGER, DIMENSION(profdata%nvar) :: iosdvobsmpp !  - outside space domain 
     306      INTEGER, DIMENSION(profdata%nvar) :: ilanvobsmpp !  - within a model land cell 
     307      INTEGER, DIMENSION(profdata%nvar) :: inlavobsmpp !  - close to land 
     308      INTEGER, DIMENSION(profdata%nvar) :: ibdyvobsmpp !  - boundary 
     309      INTEGER :: igrdobsmpp                            !  - fail the grid search 
     310      INTEGER :: iuvchkumpp                            !  - reject UVEL if VVEL rejected 
     311      INTEGER :: iuvchkvmpp                            !  - reject VVEL if UVEL rejected 
    323312      TYPE(obs_prof_valid) ::  llvalid      ! Profile selection  
    324313      TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & 
    325          & llvvalid           ! var1,var2 selection  
     314         & llvvalid           ! var selection  
    326315      INTEGER :: jvar         ! Variable loop variable 
    327316      INTEGER :: jobs         ! Obs. loop variable 
    328317      INTEGER :: jstp         ! Time loop variable 
    329318      INTEGER :: inrc         ! Time index variable 
     319      CHARACTER(LEN=256) :: cout1  ! Diagnostic output line 
     320      CHARACTER(LEN=256) :: cout2  ! Diagnostic output line 
    330321      !!---------------------------------------------------------------------- 
    331322 
    … …  
    342333      icycle = nn_no     ! Assimilation cycle 
    343334 
    344       ! Diagnotics counters for various failures. 
    345  
    346       iotdobs   = 0 
    347       igrdobs   = 0 
    348       iosdv1obs = 0 
    349       iosdv2obs = 0 
    350       ilanv1obs = 0 
    351       ilanv2obs = 0 
    352       inlav1obs = 0 
    353       inlav2obs = 0 
    354       ibdyv1obs = 0 
    355       ibdyv2obs = 0 
    356       iuvchku   = 0 
    357       iuvchkv   = 0 
     335      ! Diagnostic counters for various failures. 
     336 
     337      iotdobs     = 0 
     338      igrdobs     = 0 
     339      iosdvobs(:) = 0 
     340      ilanvobs(:) = 0 
     341      inlavobs(:) = 0 
     342      ibdyvobs(:) = 0 
     343      iuvchku     = 0 
     344      iuvchkv     = 0 
    358345 
    359346 
    … …  
    388375      ! ----------------------------------------------------------------------- 
    389376 
    390       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,1), profdata%mj(:,1), & 
    391          &              profdata%nqc,     igrdobs                         ) 
    392       CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,2), profdata%mj(:,2), & 
    393          &              profdata%nqc,     igrdobs                         ) 
     377      DO jvar = 1, profdata%nvar 
     378         CALL obs_coo_grd( profdata%nprof,   profdata%mi(:,jvar), profdata%mj(:,jvar), & 
     379            &              profdata%nqc,     igrdobs                         ) 
     380      END DO 
    394381 
    395382      CALL obs_mpp_sum_integer( igrdobs, igrdobsmpp ) 
    … …  
    406393      ! ----------------------------------------------------------------------- 
    407394 
    408       ! Variable 1 
    409       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(1),   & 
    410          &                 profdata%npvsta(:,1),  profdata%npvend(:,1), & 
    411          &                 jpi,                   jpj,                  & 
    412          &                 jpk,                                         & 
    413          &                 profdata%mi,           profdata%mj,          & 
    414          &                 profdata%var(1)%mvk,                         & 
    415          &                 profdata%rlam,         profdata%rphi,        & 
    416          &                 profdata%var(1)%vdep,                        & 
    417          &                 pglam1,                pgphi1,               & 
    418          &                 gdept_1d,              zmask1,               & 
    419          &                 profdata%nqc,          profdata%var(1)%nvqc, & 
    420          &                 iosdv1obs,             ilanv1obs,            & 
    421          &                 inlav1obs,             ld_nea,               & 
    422          &                 ibdyv1obs,             ld_bound_reject,      & 
    423          &                 iqc_cutoff,            Kmm                 ) 
    424  
    425       CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) 
    426       CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) 
    427       CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) 
    428       CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) 
    429  
    430       ! Variable 2 
    431       CALL obs_coo_spc_3d( profdata%nprof,        profdata%nvprot(2),   & 
    432          &                 profdata%npvsta(:,2),  profdata%npvend(:,2), & 
    433          &                 jpi,                   jpj,                  & 
    434          &                 jpk,                                         & 
    435          &                 profdata%mi,           profdata%mj,          &  
    436          &                 profdata%var(2)%mvk,                         & 
    437          &                 profdata%rlam,         profdata%rphi,        & 
    438          &                 profdata%var(2)%vdep,                        & 
    439          &                 pglam2,                pgphi2,               & 
    440          &                 gdept_1d,              zmask2,               & 
    441          &                 profdata%nqc,          profdata%var(2)%nvqc, & 
    442          &                 iosdv2obs,             ilanv2obs,            & 
    443          &                 inlav2obs,             ld_nea,               & 
    444          &                 ibdyv2obs,             ld_bound_reject,      & 
    445          &                 iqc_cutoff,            Kmm                 ) 
    446  
    447       CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) 
    448       CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) 
    449       CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) 
    450       CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) 
     395      DO jvar = 1, profdata%nvar 
     396         CALL obs_coo_spc_3d( profdata%nprof,          profdata%nvprot(jvar),   & 
     397            &                 profdata%npvsta(:,jvar), profdata%npvend(:,jvar), & 
     398            &                 jpi,                     jpj,                     & 
     399            &                 jpk,                                              & 
     400            &                 profdata%mi,             profdata%mj,             & 
     401            &                 profdata%var(jvar)%mvk,                           & 
     402            &                 profdata%rlam,           profdata%rphi,           & 
     403            &                 profdata%var(jvar)%vdep,                          & 
     404            &                 pglam(:,:,jvar),         pgphi(:,:,jvar),         & 
     405            &                 gdept_1d,                zmask(:,:,:,jvar),       & 
     406            &                 profdata%nqc,            profdata%var(jvar)%nvqc, & 
     407            &                 iosdvobs(jvar),          ilanvobs(jvar),          & 
     408            &                 inlavobs(jvar),          ld_nea,                  & 
     409            &                 ibdyvobs(jvar),          ld_bound_reject,         & 
     410            &                 iqc_cutoff,              Kmm       ) 
     411 
     412         CALL obs_mpp_sum_integer( iosdvobs(jvar), iosdvobsmpp(jvar) ) 
     413         CALL obs_mpp_sum_integer( ilanvobs(jvar), ilanvobsmpp(jvar) ) 
     414         CALL obs_mpp_sum_integer( inlavobs(jvar), inlavobsmpp(jvar) ) 
     415         CALL obs_mpp_sum_integer( ibdyvobs(jvar), ibdyvobsmpp(jvar) ) 
     416      END DO 
    451417 
    452418      ! ----------------------------------------------------------------------- 
    … …  
    499465       
    500466         WRITE(numout,*) 
    501          WRITE(numout,*) ' Profiles outside time domain                     = ', & 
     467         WRITE(numout,*) ' Profiles outside time domain                       = ', & 
    502468            &            iotdobsmpp 
    503          WRITE(numout,*) ' Remaining profiles that failed grid search       = ', & 
     469         WRITE(numout,*) ' Remaining profiles that failed grid search         = ', & 
    504470            &            igrdobsmpp 
    505          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain       = ', & 
    506             &            iosdv1obsmpp 
    507          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points             = ', & 
    508             &            ilanv1obsmpp 
    509          IF (ld_nea) THEN 
    510             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& 
    511                &            inlav1obsmpp 
    512          ELSE 
    513             WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept)    = ',& 
    514                &            inlav1obsmpp 
    515          ENDIF 
    516          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    517             WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
    518                &            iuvchku 
    519          ENDIF 
    520          WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& 
    521                &            ibdyv1obsmpp 
    522          WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted                             = ', & 
    523             &            prodatqc%nvprotmpp(1) 
    524          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain       = ', & 
    525             &            iosdv2obsmpp 
    526          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points             = ', & 
    527             &            ilanv2obsmpp 
    528          IF (ld_nea) THEN 
    529             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& 
    530                &            inlav2obsmpp 
    531          ELSE 
    532             WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept)    = ',& 
    533                &            inlav2obsmpp 
    534          ENDIF 
    535          IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN 
    536             WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
    537                &            iuvchkv 
    538          ENDIF 
    539          WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& 
    540                &            ibdyv2obsmpp 
    541          WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted                             = ', & 
    542             &            prodatqc%nvprotmpp(2) 
     471         DO jvar = 1, profdata%nvar 
     472            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data outside space domain       = ', & 
     473               &            iosdvobsmpp(jvar) 
     474            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data at land points             = ', & 
     475               &            ilanvobsmpp(jvar) 
     476            IF (ld_nea) THEN 
     477               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (removed) = ',& 
     478                  &            inlavobsmpp(jvar) 
     479            ELSE 
     480               WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near land points (kept)    = ',& 
     481                  &            inlavobsmpp(jvar) 
     482            ENDIF 
     483            IF ( TRIM(profdata%cvars(jvar)) == 'UVEL' ) THEN 
     484               WRITE(numout,*) ' U observation rejected since V rejected     = ', & 
     485                  &            iuvchku 
     486            ELSE IF ( TRIM(profdata%cvars(jvar)) == 'VVEL' ) THEN 
     487               WRITE(numout,*) ' V observation rejected since U rejected     = ', & 
     488                  &            iuvchkv 
     489            ENDIF 
     490            WRITE(numout,*) ' Remaining '//prodatqc%cvars(jvar)//' data near open boundary (removed) = ',& 
     491                  &            ibdyvobsmpp(jvar) 
     492            WRITE(numout,*) ' '//prodatqc%cvars(jvar)//' data accepted                             = ', & 
     493               &            prodatqc%nvprotmpp(jvar) 
     494         END DO 
    543495 
    544496         WRITE(numout,*) 
    545497         WRITE(numout,*) ' Number of observations per time step :' 
    546498         WRITE(numout,*) 
    547          WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & 
    548             &                               '     '//prodatqc%cvars(1)//'     ', & 
    549             &                               '     '//prodatqc%cvars(2)//'     ' 
    550          WRITE(numout,998) 
     499         WRITE(cout1,'(10X,A9,5X,A8)') 'Time step', 'Profiles' 
     500         WRITE(cout2,'(10X,A9,5X,A8)') '---------', '--------' 
     501         DO jvar = 1, prodatqc%nvar 
     502            WRITE(cout1,'(A,5X,A11)') TRIM(cout1), TRIM(prodatqc%cvars(jvar)) 
     503            WRITE(cout2,'(A,5X,A11)') TRIM(cout2), '-----------' 
     504         END DO 
     505         WRITE(numout,*) cout1 
     506         WRITE(numout,*) cout2 
    551507      ENDIF 
    552508       
    … …  
    575531         DO jstp = nit000 - 1, nitend 
    576532            inrc = jstp - nit000 + 2 
    577             WRITE(numout,999) jstp, prodatqc%npstpmpp(inrc), & 
    578                &                    prodatqc%nvstpmpp(inrc,1), & 
    579                &                    prodatqc%nvstpmpp(inrc,2) 
     533            WRITE(cout1,'(10X,I9,5X,I8)') jstp, prodatqc%npstpmpp(inrc) 
     534            DO jvar = 1, prodatqc%nvar 
     535               WRITE(cout1,'(A,5X,I11)') TRIM(cout1), prodatqc%nvstpmpp(inrc,jvar) 
     536            END DO 
     537            WRITE(numout,*) cout1 
    580538         END DO 
    581539      ENDIF 
    582  
    583 998   FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') 
    584 999   FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) 
    585540 
    586541   END SUBROUTINE obs_pre_prof 
Note: See TracChangeset for help on using the changeset viewer.