source: NEMO/branches/2019/dev_r11879_ENHANCE-05_SimonM-Harmonic_Analysis/src/OCE/DIA/diamlr.F90 @ 11950

MODULE diamlr
   !!======================================================================
   !!                       ***  MODULE  diamlr  ***
   !! Management of the IOM context for multiple-linear-regression analysis
   !!======================================================================
   !! History :       !  2019  (S. Mueller)
   !!----------------------------------------------------------------------

   USE par_oce        , ONLY :   wp, jpi, jpj
   USE phycst         , ONLY :   rpi
   USE in_out_manager , ONLY :   lwp, numout, ln_timing
   USE iom            , ONLY :   iom_put, iom_use, iom_update_file_name
   USE dom_oce        , ONLY :   adatrj
   USE timing         , ONLY :   timing_start, timing_stop
   USE xios
   USE tide_mod       , ONLY :   tide_harmo, jpmax_harmo, Wave

   IMPLICIT NONE
   PRIVATE

   LOGICAL, PUBLIC ::   lk_diamlr = .FALSE.

   PUBLIC ::   dia_mlr_init, dia_mlr_iom_init, dia_mlr

   !!----------------------------------------------------------------------
   !! NEMO/OCE 4.0 , NEMO Consortium (2019)
   !! $Id$
   !! Software governed by the CeCILL license (see ./LICENSE)
   !!----------------------------------------------------------------------
CONTAINS
   
   SUBROUTINE dia_mlr_init
      !!----------------------------------------------------------------------
      !!                 ***  ROUTINE dia_mlr_init  ***
      !!
      !! ** Purpose : initialisation of IOM context management for 
      !!              multiple-linear-regression analysis
      !!
      !!----------------------------------------------------------------------

      lk_diamlr = .TRUE.

      IF(lwp) THEN
         WRITE(numout, *)
         WRITE(numout, *) 'dia_mlr_init : initialisation of IOM context management for'
         WRITE(numout, *) '~~~~~~~~~~~~   multiple-linear-regression analysis'
      END IF

   END SUBROUTINE dia_mlr_init

   SUBROUTINE dia_mlr_iom_init
      !!----------------------------------------------------------------------
      !!               ***  ROUTINE dia_mlr_iom_init  ***
      !!
      !! ** Purpose : IOM context setup for multiple-linear-regression
      !!              analysis
      !!
      !!----------------------------------------------------------------------

      TYPE(xios_fieldgroup)                       ::   slxhdl_fldgrp
      TYPE(xios_filegroup)                        ::   slxhdl_filgrp
      TYPE(xios_field), ALLOCATABLE, DIMENSION(:) ::   slxhdl_regs, slxhdl_flds
      TYPE(xios_field)                            ::   slxhdl_fld
      TYPE(xios_file)                             ::   slxhdl_fil
      LOGICAL                                     ::   slxatt_enabled
      CHARACTER(LEN=256)                          ::   slxatt_expr
      CHARACTER(LEN=32)                           ::   slxatt_name1,   slxatt_name2
      CHARACTER(LEN=32)                           ::   slxatt_gridref, slxatt_fieldref
      INTEGER, PARAMETER                          ::   jpscanmax = 999
      INTEGER                                     ::   ireg, ifld
      CHARACTER(LEN=3)                            ::   cl3i
      CHARACTER(LEN=6)                            ::   cl6a
      CHARACTER(LEN=1)                            ::   clgt
      CHARACTER(LEN=2)                            ::   clgd
      CHARACTER(LEN=25)                           ::   clfloat
      CHARACTER(LEN=32)                           ::   clrepl
      INTEGER                                     ::   jl, jm, jn
      INTEGER                                     ::   itide                       ! Number of available tidal components
      INTEGER,  ALLOCATABLE, DIMENSION(:)         ::   itide_const                 ! Index list of selected tidal constituents
      REAL(wp), ALLOCATABLE, DIMENSION(:)         ::   ztide_omega, ztide_u,   &   ! Tidal frequency, phase, nodal correction
         &                                             ztide_v, ztide_f
      REAL(wp)                                    ::   ztide_phase                 ! Tidal-constituent phase at adatrj=0

      IF(lwp) THEN
         WRITE(numout, *)
         WRITE(numout, *) 'dia_mlr_iom_init : IOM context setup for multiple-linear-regression'
         WRITE(numout, *) '~~~~~~~~~~~~~~~~'
      END IF

      ! Get handles to multiple-linear-regression analysis configuration (field
      ! group 'diamrl_fields' and file group 'diamlr_files'); if no suitable
      ! configuration is found, disable diamlr
      IF ( lk_diamlr .AND. xios_is_valid_fieldgroup( "diamlr_fields" ) .AND. xios_is_valid_field( "diamlr_time" ) .AND.   &
         & xios_is_valid_filegroup( "diamlr_files" ) ) THEN
         CALL xios_get_handle("diamlr_fields", slxhdl_fldgrp)
         CALL xios_get_handle("diamlr_files",  slxhdl_filgrp)
      ELSE
         IF (lwp) THEN
            WRITE(numout, *) "diamlr: configuration not found or icomplete (field group 'diamlr_fields'"
            WRITE(numout, *) "        and/or file group 'diamlr_files' and/or field 'diamlr_time' missing);"
            WRITE(numout, *) "        disabling output for multiple-linear-regression analysis."
         END IF
         lk_diamlr = .FALSE.
      END IF

      ! Set up IOM context for multiple-linear-regression analysis
      IF ( lk_diamlr ) THEN

         ! Set up output files for grid types scalar, grid_T, grid_U, grid_V,
         ! and grid_W
         DO jm = 1, 5
            SELECT CASE( jm )
            CASE( 1 )
               cl6a = 'scalar'
            CASE( 2 )
               cl6a = 'grid_T'
            CASE( 3 )
               cl6a = 'grid_U'
            CASE( 4 )
               cl6a = 'grid_V'
            CASE( 5 )
               cl6a = 'grid_W'
            END SELECT
            CALL xios_add_child      ( slxhdl_filgrp, slxhdl_fil, "diamlr_file_"//cl6a )
            CALL xios_set_attr       ( slxhdl_fil, name_suffix="_diamlr_"//cl6a,   &
               &                       description="Intermediary output for multiple-linear-regression analysis - "//cl6a )
            CALL iom_update_file_name( "diamlr_file_"//cl6a )
         END DO

         ! Compile lists of active regressors and of fields selected for
         ! analysis (fields "diamlr_r<nnn>" and "diamlr_f<nnn>", where <nnn> is
         ! a 3-digit integer); also carry out placeholder substitution of tidal
         ! parameters in regressor expressions
         !
         ALLOCATE( slxhdl_regs( jpscanmax ), slxhdl_flds( jpscanmax ) )
         ireg = 0
         ifld = 0
         !
         ! Retrieve information (frequency, phase, nodal correction) about all
         ! available tidal constituents for placeholder substitution below
         itide = jpmax_harmo
         ALLOCATE(itide_const(itide), ztide_omega(itide), ztide_u(itide), ztide_v(itide), ztide_f(itide))
         DO jn = 1, itide
            itide_const(jn) = jn   ! Select all available tidal constituents
         END DO
         CALL tide_harmo( ztide_omega, ztide_v, ztide_u, ztide_f, itide_const, itide )
         
         DO jm = 1, jpscanmax
            WRITE (cl3i, '(i3.3)') jm

            ! Look for regressor
            IF ( xios_is_valid_field( "diamlr_r"//cl3i ) ) THEN

               CALL xios_get_handle( "diamlr_r"//cl3i, slxhdl_regs(ireg+1) )
               ! Retrieve pre-configured value of "enabled" attribute and
               ! regressor expression
               CALL xios_get_attr  ( slxhdl_regs(ireg+1), enabled=slxatt_enabled, expr=slxatt_expr )
               ! If enabled, keep handle in list of active regressors; also
               ! substitute placeholders for tidal frequencies, phases, and
               ! nodal corrections in regressor expressions
               IF ( slxatt_enabled ) THEN

                  ! Substitution of placeholders for tidal-constituent
                  ! parameters (amplitudes, angular veloccities, nodal phase
                  ! correction) with values that have been obtained from the
                  ! tidal-forcing implementation
                  DO jn = 1, itide
                     ! Compute phase of tidal constituent (incl. current nodal
                     ! correction) at the start of the model run (i.e. for
                     ! adatrj=0)
                     ztide_phase = MOD( ztide_u(jn) +  ztide_v(jn) - adatrj * 86400.0_wp * ztide_omega(jn), 2.0_wp * rpi )
                     clrepl = "__TDE_"//TRIM( Wave(jn)%cname_tide )//"_omega__"
                     DO WHILE ( INDEX( slxatt_expr, TRIM( clrepl ) ) > 0 )
                        WRITE (clfloat, '(e25.18)') ztide_omega(jn)
                        jl = INDEX( slxatt_expr, TRIM( clrepl ) )
                        slxatt_expr = slxatt_expr(1:jl - 1)//clfloat//slxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( slxatt_expr ) ))
                     END DO
                     clrepl = "__TDE_"//TRIM( Wave(jn)%cname_tide )//"_phase__"
                     DO WHILE ( INDEX( slxatt_expr, TRIM( clrepl ) ) > 0 )
                        WRITE (clfloat, '(e25.18)') ztide_phase
                        jl = INDEX( slxatt_expr, TRIM( clrepl ) )
                        slxatt_expr = slxatt_expr(1:jl - 1)//clfloat//slxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( slxatt_expr ) ))
                     END DO
                     clrepl = "__TDE_"//TRIM( Wave(jn)%cname_tide )//"_amplitude__"
                     DO WHILE (INDEX( slxatt_expr, TRIM( clrepl ) ) > 0 )
                        WRITE (clfloat, '(e25.18)') ztide_f(jn)
                        jl = INDEX( slxatt_expr, TRIM( clrepl ) )
                        slxatt_expr = slxatt_expr(1:jl - 1)//clfloat//slxatt_expr(jl + LEN( TRIM( clrepl ) ):LEN( TRIM( slxatt_expr ) ))
                     END DO
                  END DO

                  ! Set name attribute (and overwrite possible pre-configured name)
                  ! with field id to enable id string retrieval from stored handle
                  ! below; also re-set expression with possible substitutions
                  CALL xios_set_attr  ( slxhdl_regs(ireg+1), name="diamlr_r"//cl3i, expr=TRIM( slxatt_expr ) )

                  ireg = ireg + 1   ! Accept regressor in list of active regressors

               END IF
            END IF

            ! Look for field
            IF ( xios_is_valid_field( "diamlr_f"//cl3i ) ) THEN

               CALL xios_get_handle( "diamlr_f"//cl3i, slxhdl_flds(ifld+1) )
               ! Retrieve pre-configured value of "enabled" attribute
               CALL xios_get_attr  ( slxhdl_flds(ifld+1), enabled=slxatt_enabled )
               ! If enabled, keep handle in list of fields selected for analysis
               IF ( slxatt_enabled ) THEN
                  
                  ! Set name attribute (and overwrite possible pre-configured name)
                  ! with field id to enable id string retrieval from stored handle
                  ! below
                  CALL xios_set_attr  ( slxhdl_flds(ifld+1), name="diamlr_f"//cl3i )

                  ifld = ifld + 1   ! Accept field in list of fields selected for analysis

               END IF
            END IF

         END DO

         ! Release tidal data
         DEALLOCATE( itide_const, ztide_omega, ztide_u, ztide_v, ztide_f )

         ! Output number of active regressors and fields selected for analysis
         IF ( lwp ) WRITE(numout,'(a,i3,a)' ) 'diamlr: ', ireg, ' active regressors found'
         IF ( lwp ) WRITE(numout,'(a,i3,a)' ) 'diamlr: ', ifld, ' fields selected for analysis'

         ! For each active regressor:
         DO jm = 1, ireg

            !   i) set up 2-dimensional and 3-dimensional versions of the
            !      regressors; explicitely set "enabled" attribute; note, while
            !      the scalar versions of regressors are part of the
            !      configuration, the respective 2-dimensional versions take
            !      over the defining expression, while the scalar and
            !      3-dimensional versions are simply obtained via grid
            !      transformations from the 2-dimensional version.
            CALL xios_get_attr  ( slxhdl_regs( jm ), name=slxatt_name1, expr=slxatt_expr, enabled=slxatt_enabled )
            CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( slxatt_name1 )//"_2D" )
            CALL xios_set_attr  ( slxhdl_fld, expr=TRIM( slxatt_expr ), grid_ref="diamlr_grid_2D",     &
               &                  field_ref="diamlr_time", enabled=slxatt_enabled )
            CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( slxatt_name1 )//"_3D")
            CALL xios_set_attr  ( slxhdl_fld, expr="this", grid_ref="diamlr_grid_2D_to_3D",            &
               &                  field_ref=TRIM( slxatt_name1 )//"_2D", enabled=slxatt_enabled)
            CALL xios_set_attr  ( slxhdl_regs(jm), expr="this", grid_ref="diamlr_grid_2D_to_scalar",   &
               &                  field_ref=TRIM( slxatt_name1 )//"_2D", enabled=slxatt_enabled)

            !  ii) set up definitions for the output of scalar products with
            !      itself and with other active regressors
            CALL xios_get_attr  ( slxhdl_regs(jm), name=slxatt_name1 )
            CALL xios_get_handle( "diamlr_file_scalar", slxhdl_fil)
            DO jn = 1, jm
               ! Field for product between regressors
               CALL xios_get_attr  ( slxhdl_regs(jn), name=slxatt_name2, enabled=slxatt_enabled )
               CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( slxatt_name1 )//"."//TRIM( slxatt_name2 ) )
               ! Set appropriate name attribute to avoid the possibility of
               ! using an inappropriate inherited name attribute as the variable
               ! name in the output file
               CALL xios_set_attr  ( slxhdl_fld, name=TRIM( slxatt_name1 )//"."//TRIM( slxatt_name2 ),      &
                  &                  grid_ref="diamlr_grid_scalar", expr="this * "//TRIM( slxatt_name2 ),   &
                  &                  field_ref=TRIM( slxatt_name1 ), enabled=slxatt_enabled, operation="accumulate")
               ! Add regressor-product field to output file
               CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( slxatt_name1 )//"."//TRIM( slxatt_name2 ) )
            END DO

            ! iii) set up definitions for the output of scalar products with
            !      fields selected for analysis
            DO jn = 1, ifld
               CALL xios_get_attr( slxhdl_flds(jn), name=slxatt_name2, grid_ref=slxatt_gridref, field_ref=slxatt_fieldref )
               clgt="T"
               IF ( INDEX( slxatt_gridref, "_U_" ) > 0 ) clgt="U"
               IF ( INDEX( slxatt_gridref, "_V_" ) > 0 ) clgt="V"
               IF ( INDEX( slxatt_gridref, "_W_" ) > 0 ) clgt="W"
               clgd="2D"
               IF ( INDEX( slxatt_gridref, "_3D" ) > 0 ) clgd="3D"
               CALL xios_add_child ( slxhdl_fldgrp, slxhdl_fld, TRIM( slxatt_name2 )//"."//TRIM( slxatt_name1 ) )
               ! Set appropriate name attribute to avoid the possibility of
               ! using an inappropriate inherited name attribute as the variable
               ! name in the output file
               CALL xios_set_attr  ( slxhdl_fld, name=TRIM( slxatt_name2 )//"."//TRIM( slxatt_name1 ),         &
                  &                  expr="this * "//TRIM( slxatt_fieldref ), grid_ref="diamlr_grid_"//clgd,   &
                  &                  field_ref=TRIM( slxatt_name1 )//"_"//clgd, enabled=slxatt_enabled, operation="accumulate" )
               CALL xios_get_handle( "diamlr_file_grid_"//clgt, slxhdl_fil )
               CALL xios_add_child ( slxhdl_fil, slxhdl_fld, TRIM( slxatt_name2 )//"."//TRIM( slxatt_name1 ) )
            END DO

         END DO

         ! Release list of active regressors and fields selected for analysis
         DEALLOCATE( slxhdl_regs, slxhdl_flds )

      END IF

   END SUBROUTINE dia_mlr_iom_init

   SUBROUTINE dia_mlr
      !!----------------------------------------------------------------------
      !!                   ***  ROUTINE dia_mlr  ***
      !!
      !! ** Purpose : update time used in multiple-linear-regression analysis
      !!
      !!----------------------------------------------------------------------

      REAL(wp), DIMENSION(jpi,jpj) ::   zadatrj2d

      IF( ln_timing )   CALL timing_start('dia_mlr')

      ! Update time to the continuous time since the start of the model run
      ! (value of adatrj converted to time in units of seconds)
      !
      ! A 2-dimensional field of constant value is sent, and subsequently used
      ! directly or transformed to a scalar or a constant 3-dimensional field as
      ! required.
      zadatrj2d(:,:) = adatrj*86400.0_wp
      IF ( iom_use('diamlr_time') ) CALL iom_put('diamlr_time', zadatrj2d)
      
      IF( ln_timing )   CALL timing_stop('dia_mlr')

   END SUBROUTINE dia_mlr

END MODULE diamlr