Changeset 5704 for branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

Timestamp:

2015-08-21T15:00:38+02:00 (9 years ago)

Author:

mattmartin

Message:

Updated simplified obs operator after testing sea-ice concentration and velocity data types.

File:

• branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90 (modified) (11 diffs)

branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/OBS/diaobs.F90

@@ -137 +137 @@
       REAL(dp) :: rn_dobsini     ! Obs window start date YYYYMMDD.HHMMSS
       REAL(dp) :: rn_dobsend     ! Obs window end date   YYYYMMDD.HHMMSS
-      REAL(wp), DIMENSION(jpi,jpj) :: &
+      REAL(wp), POINTER, DIMENSION(:,:) :: &
          & zglam1, &             ! Model longitudes for profile variable 1
          & zglam2                ! Model longitudes for profile variable 2
-      REAL(wp), DIMENSION(jpi,jpj) :: &
+      REAL(wp), POINTER, DIMENSION(:,:) :: &
          & zgphi1, &             ! Model latitudes for profile variable 1
          & zgphi2                ! Model latitudes for profile variable 2
-      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
+      REAL(wp), POINTER, DIMENSION(:,:,:) :: &
          & zmask1, &             ! Model land/sea mask associated with variable 1
          & zmask2                ! Model land/sea mask associated with variable 2
@@ -159 +159 @@
          &            nn_msshc, rn_mdtcorr, rn_mdtcutoff,             &
          &            nn_profdavtypes
+
+      CALL wrk_alloc( jpi, jpj, zglam1 )
+      CALL wrk_alloc( jpi, jpj, zglam2 )
+      CALL wrk_alloc( jpi, jpj, zgphi1 )
+      CALL wrk_alloc( jpi, jpj, zgphi2 )
+      CALL wrk_alloc( jpi, jpj, jpk, zmask1 )
+      CALL wrk_alloc( jpi, jpj, jpk, zmask2 )
 
       !-----------------------------------------------------------------------
@@ -409 +416 @@
             CALL obs_pre_prof( profdata(jtype), profdataqc(jtype), &
                &               llvar1, llvar2, &
+               &               jpi, jpj, jpk, &
                &               zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2,  &
                &               ln_nea, kdailyavtypes = nn_profdavtypes )
@@ -451 +459 @@
 
       ENDIF
+
+      CALL wrk_dealloc( jpi, jpj, zglam1 )
+      CALL wrk_dealloc( jpi, jpj, zglam2 )
+      CALL wrk_dealloc( jpi, jpj, zgphi1 )
+      CALL wrk_dealloc( jpi, jpj, zgphi2 )
+      CALL wrk_dealloc( jpi, jpj, jpk, zmask1 )
+      CALL wrk_dealloc( jpi, jpj, jpk, zmask2 )
 
    END SUBROUTINE dia_obs_init
@@ -500 +515 @@
       INTEGER :: jtype             ! Data loop variable
       INTEGER :: jvar              ! Variable number
-      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
+      INTEGER :: ji, jj            ! Loop counters
+      REAL(wp), POINTER, DIMENSION(:,:,:) :: &
          & zprofvar1, &            ! Model values for 1st variable in a prof ob
          & zprofvar2               ! Model values for 2nd variable in a prof ob
-      REAL(wp), DIMENSION(jpi,jpj,jpk) :: &
+      REAL(wp), POINTER, DIMENSION(:,:,:) :: &
          & zprofmask1, &           ! Mask associated with zprofvar1
          & zprofmask2              ! Mask associated with zprofvar2
-      REAL(wp), DIMENSION(jpi,jpj)     :: &
+      REAL(wp), POINTER, DIMENSION(:,:) :: &
          & zsurfvar                ! Model values equivalent to surface ob.
-      REAL(wp), DIMENSION(jpi,jpj) :: &
+      REAL(wp), POINTER, DIMENSION(:,:) :: &
          & zglam1,    &            ! Model longitudes for prof variable 1
          & zglam2,    &            ! Model longitudes for prof variable 2
@@ -518 +534 @@
       LOGICAL :: llnightav        ! Logical for calculating night-time average
 
+      !Allocate local work arrays
+      CALL wrk_alloc( jpi, jpj, jpk, zprofvar1 )
+      CALL wrk_alloc( jpi, jpj, jpk, zprofvar2 )
+      CALL wrk_alloc( jpi, jpj, jpk, zprofmask1 )
+      CALL wrk_alloc( jpi, jpj, jpk, zprofmask2 )
+      CALL wrk_alloc( jpi, jpj, zsurfvar )
+      CALL wrk_alloc( jpi, jpj, zglam1 )
+      CALL wrk_alloc( jpi, jpj, zglam2 )
+      CALL wrk_alloc( jpi, jpj, zgphi1 )
+      CALL wrk_alloc( jpi, jpj, zgphi2 )
 #if ! defined key_lim2 && ! defined key_lim3
       CALL wrk_alloc(jpi,jpj,frld) 
@@ -591 +617 @@
 #if defined key_lim2 || defined key_lim3
             CASE('sic')
-               zsurfvar(:,:) = 1._wp - frld(:,:)
+               IF ( kstp == 0 ) THEN
+                  IF ( lwp .AND. surfdataqc(jtype)%nsstpmpp(1) > 0 ) THEN
+                     CALL ctl_warn( 'Sea-ice not initialised on zeroth '// &
+                        &           'time-step but some obs are valid then.' )
+                     WRITE(numout,*)surfdataqc(jtype)%nsstpmpp(1), &
+                        &           ' sea-ice obs will be missed'
+                  ENDIF
+                  surfdataqc(jtype)%nsurfup = surfdataqc(jtype)%nsurfup + &
+                     &                        surfdataqc(jtype)%nsstp(1)
+                  CYCLE
+               ELSE
+                  zsurfvar(:,:) = 1._wp - frld(:,:)
+               ENDIF
+
                llnightav = .FALSE.
 #endif
@@ -604 +643 @@
       ENDIF
 
+      CALL wrk_dealloc( jpi, jpj, jpk, zprofvar1 )
+      CALL wrk_dealloc( jpi, jpj, jpk, zprofvar2 )
+      CALL wrk_dealloc( jpi, jpj, jpk, zprofmask1 )
+      CALL wrk_dealloc( jpi, jpj, jpk, zprofmask2 )
+      CALL wrk_dealloc( jpi, jpj, zsurfvar )
+      CALL wrk_dealloc( jpi, jpj, zglam1 )
+      CALL wrk_dealloc( jpi, jpj, zglam2 )
+      CALL wrk_dealloc( jpi, jpj, zgphi1 )
+      CALL wrk_dealloc( jpi, jpj, zgphi2 )
 #if ! defined key_lim2 && ! defined key_lim3
-      CALL wrk_dealloc(jpi,jpj,frld) 
+      CALL wrk_dealloc(jpi,jpj,frld)
 #endif
 
    END SUBROUTINE dia_obs
 
-   SUBROUTINE dia_obs_wri 
+   SUBROUTINE dia_obs_wri
       !!----------------------------------------------------------------------
       !!                    ***  ROUTINE dia_obs_wri  ***
@@ -618 +666 @@
       !! ** Method  : Call observation diagnostic output routines
       !!
-      !! ** Action  : 
+      !! ** Action  :
       !!
       !! History :
@@ -628 +676 @@
       !!        !  15-08  (M. Martin) Combined writing for prof and surf types
       !!----------------------------------------------------------------------
+      !! * Modules used
+      USE obs_rot_vel          ! Rotation of velocities
+
       IMPLICIT NONE
 
       !! * Local declarations
       INTEGER :: jtype                    ! Data set loop variable
+      INTEGER :: jo, jvar, jk
+      REAL(wp), DIMENSION(:), ALLOCATABLE :: &
+         & zu, &
+         & zv
 
       !-----------------------------------------------------------------------
@@ -640 +695 @@
 
          DO jtype = 1, nproftypes
+
+            IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN
+
+               ! For velocity data, rotate the model velocities to N/S, E/W
+               ! using the compressed data structure.
+               ALLOCATE( &
+                  & zu(profdataqc(jtype)%nvprot(1)), &
+                  & zv(profdataqc(jtype)%nvprot(2))  &
+                  & )
+
+               CALL obs_rotvel( profdataqc(jtype), nn_2dint, zu, zv )
+
+               DO jo = 1, profdataqc(jtype)%nprof
+                  DO jvar = 1, 2
+                     DO jk = profdataqc(jtype)%npvsta(jo,jvar), profdataqc(jtype)%npvend(jo,jvar)
+
+                        IF ( jvar == 1 ) THEN
+                           profdataqc(jtype)%var(jvar)%vmod(jk) = zu(jk)
+                        ELSE
+                           profdataqc(jtype)%var(jvar)%vmod(jk) = zv(jk)
+                        ENDIF
+
+                     END DO
+                  END DO
+               END DO
+
+               DEALLOCATE( zu )
+               DEALLOCATE( zv )
+
+            END IF
 
             CALL obs_prof_decompress( profdataqc(jtype), &
                &                      profdata(jtype), .TRUE., numout )
 
-            CALL obs_wri_prof( profdata(jtype), nn_2dint )
+            CALL obs_wri_prof( profdata(jtype) )
 
          END DO