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 15224 – NEMO

Changeset 15224


Ignore:
Timestamp:
2021-09-01T17:16:18+02:00 (19 months ago)
Author:
dford
Message:

Fix treatment of extra variables for profiles, and remove a couple of unused routines.

Location:
NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS
Files:
1 deleted
4 edited

Legend:

Unmodified
Added
Removed

  • NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/diaobs.F90

    r15187 r15224  
    5656   PUBLIC dia_obs          ! Compute model equivalent to observations 
    5757   PUBLIC dia_obs_wri      ! Write model equivalent to observations 
    58    PUBLIC dia_obs_dealloc  ! Deallocate dia_obs data 
    5958   PUBLIC calc_date        ! Compute the date of a timestep 
    6059 
    … …  
    217216                  CALL obs_prof_staend( sobsgroups(jgroup)%sprofdata, jvar ) 
    218217               END DO 
     218               ! 
     219               IF ( sobsgroups(jgroup)%sprofdata%next > 0 ) THEN 
     220                  CALL obs_prof_staend_ext( sobsgroups(jgroup)%sprofdata ) 
     221               ENDIF 
    219222               ! 
    220223               CALL obs_pre_prof( sobsgroups(jgroup)%sprofdata,     & 
    … …  
    713716   END SUBROUTINE dia_obs_wri 
    714717 
    715    SUBROUTINE dia_obs_dealloc 
    716       IMPLICIT NONE 
    717       !!---------------------------------------------------------------------- 
    718       !!                    *** ROUTINE dia_obs_dealloc *** 
    719       !! 
    720       !!  ** Purpose : To deallocate data to enable the obs_oper online loop. 
    721       !!               Specifically: dia_obs_init --> dia_obs --> dia_obs_wri 
    722       !! 
    723       !!  ** Method : Clean up various arrays left behind by the obs_oper. 
    724       !! 
    725       !!  ** Action : 
    726       !! 
    727       !!---------------------------------------------------------------------- 
    728       ! obs_grid deallocation 
    729       CALL obs_grid_deallocate 
    730        
    731       !!! DEALLOC sdobsgroups/components? 
    732  
    733    END SUBROUTINE dia_obs_dealloc 
    734  
    735718   SUBROUTINE calc_date( kstp, ddobs ) 
    736719      !!---------------------------------------------------------------------- 

  • NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_profiles_def.F90

    r15180 r15224  
    4343      & obs_prof_alloc,     & 
    4444      & obs_prof_alloc_var, & 
     45      & obs_prof_alloc_ext, & 
    4546      & obs_prof_dealloc,   & 
    4647      & obs_prof_compress,  & 
    4748      & obs_prof_decompress,& 
    48       & obs_prof_staend 
     49      & obs_prof_staend,    & 
     50      & obs_prof_staend_ext 
    4951 
    5052   !! * Type definition for valid observations 
    … …  
    8688 
    8789   END TYPE obs_prof_var 
     90 
     91   !! * Type definition for extra variables 
     92 
     93   TYPE obs_prof_ext 
     94 
     95      ! Arrays with size equal to the number of observations 
     96 
     97      INTEGER, POINTER, DIMENSION(:) :: & 
     98         & nepidx,&       !: Profile number 
     99         & nelidx         !: Level number in profile 
     100 
     101      REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
     102         & eobs           !: Profile data 
     103 
     104      INTEGER, POINTER, DIMENSION(:) :: & 
     105         & neind          !: Source indices of temp. data in compressed data 
     106 
     107   END TYPE obs_prof_ext 
    88108 
    89109   !! * Type definition for profile observation type 
    … …  
    128148 
    129149      INTEGER, POINTER, DIMENSION(:) :: & 
    130          & nvprot,   &    !: Local total number of profile T data 
    131          & nvprotmpp      !: Global total number of profile T data 
     150         & nvprot,   &    !: Local total number of profile data 
     151         & nvprotmpp      !: Global total number of profile data 
    132152       
    133153      ! Arrays with size equal to the number of profiles 
    … …  
    160180         & npvsta, &      !: Start of each variable profile in full arrays 
    161181         & npvend, &      !: End of each variable profile in full arrays 
    162          & mi,     &      !: i-th grid coord. for interpolating to profile T data 
    163          & mj,     &      !: j-th grid coord. for interpolating to profile T data 
     182         & mi,     &      !: i-th grid coord. for interpolating to profile data 
     183         & mj,     &      !: j-th grid coord. for interpolating to profile data 
    164184         & ivqc           !: QC flags for all levels for a variable 
    165185 
    … …  
    180200      TYPE(obs_prof_var), POINTER, DIMENSION(:) :: var 
    181201 
    182       REAL(KIND=wp), POINTER, DIMENSION(:,:) :: & 
    183          & vext        !: Extra variables 
     202      ! Extra variables 
     203 
     204      TYPE(obs_prof_ext) :: vext 
     205 
     206      INTEGER :: nvprotext  !: Local total number of extra variable profile data 
     207 
     208      INTEGER, POINTER, DIMENSION(:) :: & 
     209         & npvstaext, &      !: Start of extra variable profiles in full arrays 
     210         & npvendext         !: End of extra variable profiles in full arrays 
    184211 
    185212      ! Arrays with size equal to the number of time steps in the window 
    … …  
    221248    
    222249   SUBROUTINE obs_prof_alloc( prof,  kvar, kadd, kext, kprof,  & 
    223       &                       ko3dt, kstp, kpi, kpj, kpk ) 
     250      &                       ko3dt, ke3dt, kstp, kpi, kpj, kpk ) 
    224251      !!---------------------------------------------------------------------- 
    225252      !!                     ***  ROUTINE obs_prof_alloc  *** 
    … …  
    241268      INTEGER, INTENT(IN), DIMENSION(kvar) :: & 
    242269         & ko3dt     ! Number of observations per variables 
     270      INTEGER, INTENT(IN) :: ke3dt  ! Number of observations per extra variables 
    243271      INTEGER, INTENT(IN) :: kstp   ! Number of time steps 
    244272      INTEGER, INTENT(IN) :: kpi    ! Number of 3D grid points 
    … …  
    362390 
    363391      DO jvar = 1, kvar 
    364  
    365392         IF ( ko3dt(jvar) >= 0 ) THEN 
    366393            CALL obs_prof_alloc_var( prof, jvar, kadd, ko3dt(jvar) ) 
    367394         ENDIF 
    368           
    369       END DO 
    370        
    371       ! Allocate extra variables 
    372       ALLOCATE( & 
    373          & prof%vext(kprof,kext) & 
    374          & ) 
     395      END DO 
     396       
     397      ! Extra variables 
     398 
     399      IF ( kext > 0 ) THEN 
     400         prof%nvprotext = ke3dt 
     401         ALLOCATE( & 
     402            & prof%npvstaext(kprof), &   
     403            & prof%npvendext(kprof) ) 
     404         CALL obs_prof_alloc_ext( prof, kext, ke3dt ) 
     405      ELSE 
     406         prof%nvprotext = 0 
     407      ENDIF 
    375408 
    376409      ! Allocate arrays of size number of time step size 
    … …  
    407440         END DO 
    408441      END DO 
     442 
     443      IF ( kext > 0 ) THEN 
     444         DO ji = 1, ke3dt 
     445            prof%vext%neind(ji) = ji 
     446         END DO 
     447      ENDIF 
    409448 
    410449      ! Set defaults for number of observations per time step 
    … …  
    438477      !!* Local variables 
    439478      INTEGER :: & 
    440          & jvar 
     479         & jvar, & 
     480         & jext 
    441481 
    442482      ! Deallocate arrays of size number of profiles 
    … …  
    479519 
    480520      DO jvar = 1, prof%nvar 
    481  
    482521         IF ( prof%nvprot(jvar) >= 0 ) THEN 
    483  
    484522            CALL obs_prof_dealloc_var( prof, jvar ) 
    485  
    486523         ENDIF 
    487           
    488524      END DO 
    489525 
    … …  
    494530 
    495531      ! Deallocate extra variables 
    496       DEALLOCATE( & 
    497          & prof%vext & 
    498          & ) 
     532      IF ( prof%next > 0 ) THEN 
     533         DEALLOCATE( & 
     534            & prof%npvstaext, &   
     535            & prof%npvendext  & 
     536            ) 
     537         CALL obs_prof_dealloc_ext( prof ) 
     538      ENDIF 
    499539       
    500540      ! Deallocate arrays of size number of time step size 
    … …  
    541581         & prof%cextunit  & 
    542582         ) 
    543  
    544583 
    545584   END SUBROUTINE obs_prof_dealloc 
    … …  
    586625   END SUBROUTINE obs_prof_alloc_var 
    587626 
     627 
    588628   SUBROUTINE obs_prof_dealloc_var( prof, kvar ) 
    589629 
    590630      !!---------------------------------------------------------------------- 
    591       !!                     ***  ROUTINE obs_prof_alloc_var  *** 
     631      !!                     ***  ROUTINE obs_prof_dealloc_var  *** 
    592632      !!                       
    593       !! ** Purpose : - Allocate data for variable data in profile arrays 
     633      !! ** Purpose : - Deallocate data for variable data in profile arrays 
    594634      !!  
    595635      !! ** Method  : - Fortran-90 dynamic arrays 
    … …  
    598638      !!        !  07-03  (K. Mogensen) Original code 
    599639      !! * Arguments 
    600       TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be allocated 
     640      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be deallocated 
    601641      INTEGER, INTENT(IN) :: kvar      ! Variable number 
    602642       
    … …  
    622662   END SUBROUTINE obs_prof_dealloc_var 
    623663 
     664 
     665   SUBROUTINE obs_prof_alloc_ext( prof, kext, kobs ) 
     666 
     667      !!---------------------------------------------------------------------- 
     668      !!                     ***  ROUTINE obs_prof_alloc_ext  *** 
     669      !!                       
     670      !! ** Purpose : - Allocate data for extra variables in profile arrays 
     671      !!  
     672      !! ** Method  : - Fortran-90 dynamic arrays 
     673      !! 
     674      !! History : 
     675      !!        !  07-03  (K. Mogensen) Original code 
     676      !! * Arguments 
     677      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be allocated 
     678      INTEGER,        INTENT(IN)    :: kext   ! Number of extra variables 
     679      INTEGER,        INTENT(IN)    :: kobs   ! Number of observations 
     680 
     681      ALLOCATE( & 
     682         & prof%vext%nepidx(kobs),   & 
     683         & prof%vext%nelidx(kobs),   & 
     684         & prof%vext%neind(kobs),    & 
     685         & prof%vext%eobs(kobs,kext) & 
     686         & ) 
     687 
     688   END SUBROUTINE obs_prof_alloc_ext 
     689 
     690 
     691   SUBROUTINE obs_prof_dealloc_ext( prof ) 
     692 
     693      !!---------------------------------------------------------------------- 
     694      !!                     ***  ROUTINE obs_prof_dealloc_var  *** 
     695      !!                       
     696      !! ** Purpose : - Deallocate data for extra variables in profile arrays 
     697      !!  
     698      !! ** Method  : - Fortran-90 dynamic arrays 
     699      !! 
     700      !! History : 
     701      !!        !  07-03  (K. Mogensen) Original code 
     702      !! * Arguments 
     703      TYPE(obs_prof), INTENT(INOUT) :: prof   ! Profile data to be deallocated 
     704       
     705      DEALLOCATE( & 
     706         & prof%vext%nepidx, & 
     707         & prof%vext%nelidx, & 
     708         & prof%vext%eobs,   & 
     709         & prof%vext%neind   & 
     710         & ) 
     711 
     712   END SUBROUTINE obs_prof_dealloc_ext 
     713 
     714 
    624715   SUBROUTINE obs_prof_compress( prof,   newprof, lallocate, & 
    625       &                          kumout, lvalid,   lvvalid ) 
     716      &                          kumout, lvalid,  lvvalid ) 
    626717      !!---------------------------------------------------------------------- 
    627718      !!                     ***  ROUTINE obs_prof_compress  *** 
    … …  
    644735      TYPE(obs_prof), INTENT(IN)    :: prof      ! Original profile 
    645736      TYPE(obs_prof), INTENT(INOUT) :: newprof   ! New profile with the copy of the data 
    646       LOGICAL :: lallocate                ! Allocate newprof data 
    647       INTEGER,INTENT(IN) :: kumout        ! Fortran unit for messages 
     737      LOGICAL,        INTENT(IN)    :: lallocate ! Allocate newprof data 
     738      INTEGER,        INTENT(IN)    :: kumout    ! Fortran unit for messages 
    648739      TYPE(obs_prof_valid), OPTIONAL, INTENT(in) :: & 
    649740         & lvalid        ! Valid profiles 
    … …  
    655746      INTEGER, DIMENSION(prof%nvar) :: & 
    656747         & invpro 
     748      INTEGER :: invproext 
    657749      INTEGER :: jvar 
    658750      INTEGER :: jadd 
    … …  
    668760      LOGICAL :: lnonepresent 
    669761 
    670       ! Check that either all or none of the masks are persent. 
     762      ! Check that either all or none of the masks are present. 
    671763 
    672764      lallpresent  = .FALSE. 
    … …  
    688780         inprof = 0 
    689781         invpro(:) = 0 
     782         invproext = 0 
    690783         DO ji = 1, prof%nprof 
    691784            IF ( lvalid%luse(ji) ) THEN 
    … …  
    697790                  END DO 
    698791               END DO 
     792               IF ( prof%next > 0 ) THEN 
     793                  DO jj = prof%npvstaext(ji), prof%npvendext(ji) 
     794                     invproext = invproext + 1 
     795                  END DO 
     796               ENDIF 
    699797            ENDIF 
    700798         END DO 
    … …  
    702800         inprof    = prof%nprof 
    703801         invpro(:) = prof%nvprot(:) 
     802         invproext = prof%nvprotext 
    704803      ENDIF 
    705804 
    … …  
    710809            &                 prof%nadd, prof%next, & 
    711810            &                 inprof,    invpro,    & 
     811            &                 invproext,            & 
    712812            &                 prof%nstp, prof%npi,  & 
    713813            &                 prof%npj,  prof%npk ) 
    … …  
    736836      inprof    = 0 
    737837      invpro(:) = 0 
    738  
    739       newprof%npvsta(:,:) =  0 
    740       newprof%npvend(:,:) = -1 
     838      invproext = 0 
     839 
     840      newprof%npvsta(:,:)  =  0 
     841      newprof%npvend(:,:)  = -1 
     842      newprof%npvstaext(:) =  0 
     843      newprof%npvendext(:) = -1 
    741844       
    742845      ! Loop over source profiles 
    … …  
    837940            END DO 
    838941 
    839             DO jext = 1, prof%next 
    840                newprof%vext(inprof,jext) = prof%vext(ji,jext) 
    841             END DO 
     942            IF ( prof%next > 0 ) THEN 
     943 
     944               ! Extra variables 
     945 
     946               lfirst = .TRUE. 
     947 
     948               DO jj = prof%npvstaext(ji), prof%npvendext(ji) 
     949 
     950                  invproext = invproext + 1 
     951 
     952                  ! Book keeping information 
     953 
     954                  IF ( lfirst ) THEN 
     955                     lfirst = .FALSE. 
     956                     newprof%npvstaext(inprof) = invproext 
     957                  ENDIF 
     958                  newprof%npvendext(inprof) = invproext 
     959 
     960                  ! Variable data 
     961 
     962                  newprof%vext%nepidx(invproext) = prof%vext%nepidx(jj) 
     963                  newprof%vext%nelidx(invproext) = prof%vext%nelidx(jj) 
     964                  DO jext = 1, prof%next 
     965                     newprof%vext%eobs(invproext,jext) = prof%vext%eobs(jj,jext) 
     966                  END DO 
     967 
     968                  ! nvind is the index of the original variable data 
     969 
     970                  newprof%vext%neind(invproext)  = jj 
     971 
     972               END DO 
     973 
     974            ENDIF 
    842975 
    843976         ENDIF 
    … …  
    852985      CALL obs_mpp_sum_integers ( newprof%nvprot, newprof%nvprotmpp,& 
    853986         &                        prof%nvar ) 
     987      newprof%nvprotext = invproext 
    854988       
    855989      ! Set book keeping variables which do not depend on number of obs. 
    … …  
    8661000      newprof%cunit(:) = prof%cunit(:) 
    8671001      newprof%cgrid(:) = prof%cgrid(:) 
    868       newprof%caddvars(:) = prof%caddvars(:) 
    869       newprof%caddlong(:) = prof%caddlong(:) 
    870       newprof%caddunit(:) = prof%caddunit(:) 
    871       newprof%cextvars(:) = prof%cextvars(:) 
    872       newprof%cextlong(:) = prof%cextlong(:) 
    873       newprof%cextunit(:) = prof%cextunit(:) 
     1002      newprof%caddvars(:)   = prof%caddvars(:) 
     1003      newprof%caddlong(:,:) = prof%caddlong(:,:) 
     1004      newprof%caddunit(:,:) = prof%caddunit(:,:) 
     1005      newprof%cextvars(:)   = prof%cextvars(:) 
     1006      newprof%cextlong(:)   = prof%cextlong(:) 
     1007      newprof%cextunit(:)   = prof%cextunit(:) 
    8741008  
    8751009      ! Deallocate temporary data 
    … …  
    9711105         END DO 
    9721106 
    973          DO jext = 1, prof%next 
    974             oldprof%vext(jk,jext) = prof%vext(jj,jext) 
    975          END DO 
     1107         IF ( prof%next > 0 ) THEN 
     1108 
     1109            DO jj = prof%npvstaext(ji), prof%npvendext(ji) 
     1110 
     1111               jl = prof%vext%neind(jj) 
     1112 
     1113               oldprof%vext%nepidx(jl) = prof%vext%nepidx(jj) 
     1114               oldprof%vext%nelidx(jl) = prof%vext%nelidx(jj) 
     1115               DO jext = 1, prof%next 
     1116                  oldprof%vext%eobs(jl,jext) = prof%vext%eobs(jj,jext) 
     1117               END DO 
     1118 
     1119            END DO 
     1120 
     1121         ENDIF 
    9761122          
    9771123      END DO 
    … …  
    9831129   END SUBROUTINE obs_prof_decompress 
    9841130 
     1131 
    9851132   SUBROUTINE obs_prof_staend( prof, kvarno ) 
    9861133      !!---------------------------------------------------------------------- 
    987       !!                     ***  ROUTINE obs_prof_decompress  *** 
     1134      !!                     ***  ROUTINE obs_prof_staend  *** 
    9881135      !!                       
    9891136      !! ** Purpose : - Set npvsta and npvend of a variable within  
    … …  
    10241171 
    10251172   END SUBROUTINE obs_prof_staend 
     1173 
     1174 
     1175   SUBROUTINE obs_prof_staend_ext( prof ) 
     1176      !!---------------------------------------------------------------------- 
     1177      !!                     ***  ROUTINE obs_prof_staend_ext  *** 
     1178      !!                       
     1179      !! ** Purpose : - Set npvsta and npvend within  
     1180      !!                an obs_prof_ext type 
     1181      !! 
     1182      !! ** Method  : - Find the start and stop of a profile by searching  
     1183      !!                through the data 
     1184      !!  
     1185      !! History : 
     1186      !!        !  07-04  (K. Mogensen) Original code 
     1187      !!---------------------------------------------------------------------- 
     1188      !! * Arguments 
     1189      TYPE(obs_prof),INTENT(INOUT) :: prof     ! Profile data 
     1190 
     1191      !!* Local variables 
     1192      INTEGER :: ji 
     1193      INTEGER :: iprofno 
     1194 
     1195      !----------------------------------------------------------------------- 
     1196      ! Compute start and end bookkeeping arrays 
     1197      !----------------------------------------------------------------------- 
     1198 
     1199      prof%npvstaext(:) = prof%nvprotext + 1 
     1200      prof%npvendext(:) = -1 
     1201      DO ji = 1, prof%nvprotext 
     1202         iprofno = prof%vext%nepidx(ji) 
     1203         prof%npvstaext(iprofno) = & 
     1204            & MIN( ji, prof%npvstaext(iprofno) ) 
     1205         prof%npvendext(iprofno) = & 
     1206            & MAX( ji, prof%npvendext(iprofno) ) 
     1207      END DO 
     1208 
     1209      DO ji = 1, prof%nprof 
     1210         IF ( prof%npvstaext(ji) == ( prof%nvprotext + 1 ) ) & 
     1211            & prof%npvstaext(ji) = 0 
     1212      END DO 
     1213 
     1214   END SUBROUTINE obs_prof_staend_ext 
    10261215    
    10271216END MODULE obs_profiles_def 

  • NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_read_prof.F90

    r15187 r15224  
    613613      ENDIF 
    614614      CALL obs_prof_alloc( profdata, kvars, kadd+iadd, kextr+iextr, iprof, iv3dt, & 
    615          &                 kstp, jpi, jpj, jpk ) 
     615         &                 ip3dt, kstp, jpi, jpj, jpk ) 
    616616 
    617617      ! * Read obs/positions, QC, all variable and assign to profdata 
    … …  
    765765                     & CYCLE 
    766766 
    767                   IF (ldallatall) THEN 
     767                  IF ( ldallatall .OR. (iextr > 0) ) THEN 
    768768 
    769769                     DO jvar = 1, kvars 
    … …  
    857857                  ! Extra variables 
    858858                  IF ( iextr > 0 ) THEN 
     859                     profdata%vext%nepidx(ip3dt) = iprof 
     860                     profdata%vext%nelidx(ip3dt) = ij 
    859861                     DO jext = 1, iextr 
    860                         profdata%vext(iprof,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext) 
     862                        profdata%vext%eobs(ip3dt,kextr+jext) = inpfiles(jj)%pext(ij,ji,jext) 
    861863                     END DO 
    862864                  ENDIF 

  • NEMO/branches/UKMO/NEMO_4.0.4_generic_obs/src/OCE/OBS/obs_write.F90

    r15187 r15224  
    222222                  END DO 
    223223               ENDIF 
    224 ! MOVE OUTSIDE JVAR LOOP? 
    225                IF (iext > 0) THEN 
    226                   DO je = 1, iext 
    227                      fbdata%pext(ik,jo,je) = & 
    228                         & profdata%vext(jk,pext%ipoint(je)) 
    229                   END DO 
    230                ENDIF 
    231224            END DO 
    232225         END DO 
     226         IF (iext > 0) THEN 
     227            DO jk = profdata%npvstaext(jo), profdata%npvendext(jo) 
     228               ik = profdata%vext%nelidx(jk) 
     229               DO je = 1, iext 
     230                  fbdata%pext(ik,jo,je) = & 
     231                     & profdata%vext%eobs(jk,pext%ipoint(je)) 
     232               END DO 
     233            END DO 
     234         ENDIF 
    233235      END DO 
    234236 
Note: See TracChangeset for help on using the changeset viewer.