source: NEMO/branches/2021/dev_r14116_HPC-10_mcastril_Mixed_Precision_implementation/src/OCE/OBS/obs_sstbias.F90 @ 15540

MODULE obs_sstbias
   !!======================================================================
   !!                       ***  MODULE obs_sstbias  ***
   !! Observation diagnostics: Read the bias for SST data
   !!======================================================================
   !!----------------------------------------------------------------------
   !!   obs_app_sstbias : Driver for reading and applying the SST bias
   !!----------------------------------------------------------------------
   !! * Modules used   
   USE par_kind, ONLY : &       ! Precision variables
      & wp, &
      & dp, &
      & sp
   USE par_oce, ONLY : &        ! Domain parameters
      & jpi, &
      & jpj, &
      & jpim1
   USE in_out_manager, ONLY : & ! I/O manager
      & lwp,    &
      & numout 
   USE obs_surf_def             ! Surface observation definitions
   USE dom_oce, ONLY : &        ! Domain variables
      & tmask, &
      & tmask_i, &
      & e1t,   &
      & e2t,   &
      & gphit, &
      & glamt
   USE oce, ONLY : &           ! Model variables
      & ssh
   USE obs_inter_h2d
   USE obs_utils               ! Various observation tools
   USE obs_inter_sup
   IMPLICIT NONE
   !! * Routine accessibility
   PRIVATE
   PUBLIC obs_app_sstbias     ! Read the altimeter bias
   !! * Substitutions
#  include "single_precision_substitute.h90"

CONTAINS
   SUBROUTINE obs_app_sstbias( sstdata, k2dint, knumtypes, &
                               cl_bias_files )
      !!---------------------------------------------------------------------
      !!
      !!                   *** ROUTINE obs_app_sstbias ***
      !!
      !! ** Purpose : Read SST bias data from files and apply correction to
      !!             observations
      !!
      !! ** Method  :
      !!
      !! ** Action  :
      !!
      !! References :
      !!
      !! History : 
      !!      ! :  2014-08 (J. While) Bias correction code for SST obs,
      !!      !                      based on obs_rea_altbias
      !!----------------------------------------------------------------------
      !! * Modules used
      USE iom
      USE netcdf
      !! * Arguments

      TYPE(obs_surf), INTENT(INOUT) :: sstdata       ! SST data
      INTEGER, INTENT(IN) :: k2dint
      INTEGER, INTENT(IN) :: knumtypes !number of bias types to read in
      CHARACTER(LEN=128), DIMENSION(knumtypes), INTENT(IN) :: &
                          cl_bias_files !List of files to read
      !! * Local declarations
      INTEGER :: jobs         ! Obs loop variable
      INTEGER :: jpisstbias   ! Number of grid point in latitude for the bias
      INTEGER :: jpjsstbias   ! Number of grid point in longitude for the bias
      INTEGER :: iico         ! Grid point indices
      INTEGER :: ijco
      INTEGER :: jt
      INTEGER :: i_nx_id      ! Index to read the NetCDF file
      INTEGER :: i_ny_id      !
      INTEGER :: i_file_id    !
      INTEGER :: i_var_id
      INTEGER, DIMENSION(knumtypes) :: &
         & ibiastypes             ! Array of the bias types in each file
      REAL(dp), DIMENSION(jpi,jpj,knumtypes) :: & 
         & z_sstbias              ! Array to store the SST bias values
      REAL(dp), DIMENSION(jpi,jpj) :: & 
         & z_sstbias_2d           ! Array to store the SST bias values   
      REAL(dp), DIMENSION(1) :: &
         & zext, &
         & zobsmask
      REAL(dp), DIMENSION(2,2,1) :: &
         & zweig
      REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: &
         & zmask, &
         & zglam, &
         & zgphi
      REAL(dp), DIMENSION(:,:,:), ALLOCATABLE :: &
         & zmask_tmp, &
         & zglam_tmp, &
         & zgphi_tmp   
      REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) ::  zbias   
      REAL(dp) :: zlam
      REAL(dp) :: zphi
      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
         & igrdi, &
         & igrdj
      INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: &
         & igrdi_tmp, &
         & igrdj_tmp   
      INTEGER :: numsstbias
      INTEGER(KIND=NF90_INT) :: ifile_source
     
      INTEGER :: incfile
      INTEGER :: jtype
      INTEGER :: iret 
      INTEGER :: inumtype
      IF(lwp)WRITE(numout,*) 
      IF(lwp)WRITE(numout,*) 'obs_rea_sstbias : '
      IF(lwp)WRITE(numout,*) '----------------- '
      IF(lwp)WRITE(numout,*) 'Read SST bias '
      ! Open and read the files
      z_sstbias(:,:,:)=0.0_wp
      DO jtype = 1, knumtypes
     
         numsstbias=0
         IF(lwp)WRITE(numout,*) 'Opening ',cl_bias_files(jtype)
         CALL iom_open( cl_bias_files(jtype), numsstbias, ldstop=.FALSE. )       
         IF (numsstbias > 0) THEN
     
            !Read the bias type from the file
            !No IOM get attribute command at time of writing, 
            !so have to use NETCDF
            !routines directly - should be upgraded in the future
            iret=NF90_OPEN(TRIM(cl_bias_files(jtype)), NF90_NOWRITE, incfile)
            iret=NF90_GET_ATT( incfile, NF90_GLOBAL, "SST_source", &
                              ifile_source )
            ibiastypes(jtype) = ifile_source                 
            iret=NF90_CLOSE(incfile)       
           
            IF ( iret /= 0  ) CALL ctl_stop( &
               'obs_rea_sstbias : Cannot read bias type from file '// &
               cl_bias_files(jtype) )
            ! Get the SST bias data
            CALL iom_get( numsstbias, jpdom_global, 'tn', z_sstbias_2d(:,:), 1 )
            z_sstbias(:,:,jtype) = z_sstbias_2d(:,:)       
            ! Close the file
            CALL iom_close(numsstbias)       
         ELSE
            CALL ctl_stop('obs_read_sstbias: File '// & 
                           TRIM( cl_bias_files(jtype) )//' Not found')
         ENDIF
      END DO
           
      ! Interpolate the bias already on the model grid at the observation point
      ALLOCATE( &
         & igrdi(2,2,sstdata%nsurf), &
         & igrdj(2,2,sstdata%nsurf), &
         & zglam(2,2,sstdata%nsurf), &
         & zgphi(2,2,sstdata%nsurf), &
         & zmask(2,2,sstdata%nsurf)  )
       
      DO jobs = 1, sstdata%nsurf 
         igrdi(1,1,jobs) = sstdata%mi(jobs)-1
         igrdj(1,1,jobs) = sstdata%mj(jobs)-1
         igrdi(1,2,jobs) = sstdata%mi(jobs)-1
         igrdj(1,2,jobs) = sstdata%mj(jobs)
         igrdi(2,1,jobs) = sstdata%mi(jobs)
         igrdj(2,1,jobs) = sstdata%mj(jobs)-1
         igrdi(2,2,jobs) = sstdata%mi(jobs)
         igrdj(2,2,jobs) = sstdata%mj(jobs)
      END DO
      CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, &
         &                  igrdi, igrdj, glamt, zglam )
      CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, &
         &                  igrdi, igrdj, gphit, zgphi )
      CALL obs_int_comm_2d( 2, 2, sstdata%nsurf, jpi, jpj, &
         &                  igrdi, igrdj, tmask(:,:,1), zmask )
      DO jtype = 1, knumtypes
         
         !Find the number observations of type and allocate tempory arrays
         inumtype = COUNT( sstdata%ntyp(:) == ibiastypes(jtype) )
         ALLOCATE( &
            & igrdi_tmp(2,2,inumtype), &
            & igrdj_tmp(2,2,inumtype), &
            & zglam_tmp(2,2,inumtype), &
            & zgphi_tmp(2,2,inumtype), &
            & zmask_tmp(2,2,inumtype), &
            & zbias( 2,2,inumtype ) )
         jt=1
         DO jobs = 1, sstdata%nsurf 
            IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN
               igrdi_tmp(:,:,jt) = igrdi(:,:,jobs) 
               igrdj_tmp(:,:,jt) = igrdj(:,:,jobs)
               zglam_tmp(:,:,jt) = zglam(:,:,jobs)
               zgphi_tmp(:,:,jt) = zgphi(:,:,jobs)
               zmask_tmp(:,:,jt) = zmask(:,:,jobs)
               jt = jt +1
            ENDIF
         END DO
                         
         CALL obs_int_comm_2d( 2, 2, inumtype, jpi, jpj, &
               &           igrdi_tmp(:,:,:), igrdj_tmp(:,:,:), &
               &           z_sstbias(:,:,jtype), zbias(:,:,:) )
         jt=1
         DO jobs = 1, sstdata%nsurf
            IF ( sstdata%ntyp(jobs) == ibiastypes(jtype) ) THEN
               zlam = sstdata%rlam(jobs)
               zphi = sstdata%rphi(jobs)
               iico = sstdata%mi(jobs)
               ijco = sstdata%mj(jobs)         
               CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi,         &
                  &                   zglam_tmp(:,:,jt), &
                  &                   zgphi_tmp(:,:,jt), &
                  &                   zmask_tmp(:,:,jt), zweig, zobsmask )
               CALL obs_int_h2d( 1, 1, zweig, zbias(:,:,jt),  zext )
               ! adjust sst with bias field
               sstdata%robs(jobs,1) = sstdata%robs(jobs,1) - zext(1)
               jt=jt+1
            ENDIF
         END DO 
               
         !Deallocate arrays
         DEALLOCATE( &
         & igrdi_tmp, &
         & igrdj_tmp, &
         & zglam_tmp, &
         & zgphi_tmp, &
         & zmask_tmp, &
         & zbias )           
      END DO
      DEALLOCATE( &
         & igrdi, &
         & igrdj, &
         & zglam, &
         & zgphi, &
         & zmask )

      IF(lwp) THEN
         WRITE(numout,*) " "
         WRITE(numout,*) "SST bias correction applied successfully"
         WRITE(numout,*) "Obs types: ",ibiastypes(:), &
                              " Have all been bias corrected\n"
      ENDIF
   END SUBROUTINE obs_app_sstbias
 
END MODULE obs_sstbias