tl_diag.F

Go to the documentation of this file.

#include "cppdefs.h"
      MODULE tl_diag_mod
#ifdef TANGENT
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This routine computes various tangent linear diagnostic fields.     !
!                                                                      !
!=======================================================================
!
      implicit none
!
      PRIVATE
      PUBLIC  :: tl_diag
!
      CONTAINS
!
!***********************************************************************
      SUBROUTINE tl_diag (ng, tile)
!***********************************************************************
!
      USE mod_param
      USE mod_grid
      USE mod_ocean
      USE mod_stepping
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, tile
!
!  Local variable declarations.
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__
!
# include "tile.h"
!
# ifdef PROFILE
      CALL wclock_on (ng, itlm, 7, __line__, myfile)
# endif
      CALL tl_diag_tile (ng, tile,                                      &
     &                   lbi, ubi, lbj, ubj,                            &
     &                   imins, imaxs, jmins, jmaxs,                    &
     &                   nstp(ng), kstp(ng),                            &
     &                   grid(ng) % h,                                  &
     &                   grid(ng) % omn,                                &
# ifdef SOLVE3D
     &                   grid(ng) % tl_Hz,                              &
     &                   grid(ng) % tl_z_r,                             &
     &                   grid(ng) % tl_z_w,                             &
     &                   ocean(ng) % tl_rho,                            &
     &                   ocean(ng) % tl_u,                              &
     &                   ocean(ng) % tl_v,                              &
# endif
     &                   ocean(ng) % tl_ubar,                           &
     &                   ocean(ng) % tl_vbar,                           &
     &                   ocean(ng) % tl_zeta)
# ifdef PROFILE
      CALL wclock_off (ng, itlm, 7, __line__, myfile)
# endif
!
      RETURN
      END SUBROUTINE tl_diag
!
!***********************************************************************
      SUBROUTINE tl_diag_tile (ng, tile,                                &
     &                         LBi, UBi, LBj, UBj,                      &
     &                         IminS, ImaxS, JminS, JmaxS,              &
     &                         nstp, kstp,                              &
     &                         h, omn,                                  &
# ifdef SOLVE3D
     &                         tl_Hz, tl_z_r, tl_z_w,                   &
     &                         tl_rho, tl_u, tl_v,                      &
# endif
     &                         tl_ubar, tl_vbar, tl_zeta)
!***********************************************************************
!
      USE mod_param
      USE mod_parallel
      USE mod_iounits
      USE mod_scalars
 
# ifdef DISTRIBUTE
!
      USE distribute_mod, ONLY : mp_reduce
# endif
!
      implicit none
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, tile
      integer, intent(in) :: LBi, UBi, LBj, UBj
      integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
      integer, intent(in) :: nstp, kstp
!
# ifdef ASSUMED_SHAPE
      real(r8), intent(in) :: h(LBi:,LBj:)
      real(r8), intent(in) :: omn(LBi:,LBj:)
#  ifdef SOLVE3D
      real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:)
      real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:)
      real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:)
      real(r8), intent(in) :: tl_rho(LBi:,LBj:,:)
      real(r8), intent(in) :: tl_u(LBi:,LBj:,:,:)
      real(r8), intent(in) :: tl_v(LBi:,LBj:,:,:)
#  endif
      real(r8), intent(in) :: tl_ubar(LBi:,LBj:,:)
      real(r8), intent(in) :: tl_vbar(LBi:,LBj:,:)
      real(r8), intent(in) :: tl_zeta(LBi:,LBj:,:)
# else
      real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
      real(r8), intent(in) :: omn(LBi:UBi,LBj:UBj)
#  ifdef SOLVE3D
      real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:N(ng))
      real(r8), intent(in) :: tl_rho(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(in) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
      real(r8), intent(in) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
#  endif
      real(r8), intent(in) :: tl_ubar(LBi:UBi,LBj:UBj,:)
      real(r8), intent(in) :: tl_vbar(LBi:UBi,LBj:UBj,:)
      real(r8), intent(in) :: tl_zeta(LBi:UBi,LBj:UBj,:)
# endif
!
!  Local variable declarations.
!
      integer :: NSUB, i, j, k, trd
      integer :: idia, istep
 
# ifdef DISTRIBUTE
      real(r8), dimension(3) :: rbuffer
      character (len=3), dimension(3) :: op_handle
# else
      integer :: my_threadnum
# endif
!
      real(r8) :: cff, my_avgke, my_avgpe, my_volume
 
      real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ke2d
      real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: pe2d
!
      character (len=8 ) :: kechar, pechar
      character (len=22) :: DateTime
 
# include "set_bounds.h"
!
!-----------------------------------------------------------------------
!  Compute and report out volume averaged kinetic, potential total
!  energy, and volume of tangent linear fields. Notice that the
!  proper adjoint of these quantities are not coded.
!-----------------------------------------------------------------------
!
!  Set time timestep counter and time level indices to process. Restart
!  counter after 10 billion steps.
!
      istep=int(mod(real(iic(ng)-1,r8),1.0e+10_r8))
# ifdef SOLVE3D
      idia=nstp
# else
      idia=kstp
# endif
      datetime=time_code(ng)
!
! Compute kinetic and potential energy.
!
      IF (mod(istep,ninfo(ng)).eq.0) THEN
        DO j=jstr,jend
# ifdef SOLVE3D
          DO i=istr,iend
            ke2d(i,j)=0.0_r8
            pe2d(i,j)=0.5_r8*g*tl_z_w(i,j,n(ng))*tl_z_w(i,j,n(ng))
          END DO
          cff=g/rho0
          DO k=n(ng),1,-1
            DO i=istr,iend
              ke2d(i,j)=ke2d(i,j)+                                      &
     &                  tl_hz(i,j,k)*                                   &
     &                  0.25_r8*(tl_u(i  ,j,k,idia)*tl_u(i  ,j,k,idia)+ &
     &                           tl_u(i+1,j,k,idia)*tl_u(i+1,j,k,idia)+ &
     &                           tl_v(i,j  ,k,idia)*tl_v(i,j  ,k,idia)+ &
     &                           tl_v(i,j+1,k,idia)*tl_v(i,j+1,k,idia))
              pe2d(i,j)=pe2d(i,j)+                                      &
     &                  cff*tl_hz(i,j,k)*(tl_rho(i,j,k)+1000.0_r8)*     &
     &                  (tl_z_r(i,j,k)-tl_z_w(i,j,0))
            END DO
          END DO
# else
          cff=0.5_r8*g
          DO i=istr,iend
            ke2d(i,j)=(tl_zeta(i,j,idia)+h(i,j))*                       &
     &                0.25_r8*(tl_ubar(i  ,j,idia)*tl_ubar(i  ,j,idia)+ &
     &                         tl_ubar(i+1,j,idia)*tl_ubar(i+1,j,idia)+ &
     &                         tl_vbar(i,j  ,idia)*tl_vbar(i,j  ,idia)+ &
     &                         tl_vbar(i,j+1,idia)*tl_vbar(i,j+1,idia))
            pe2d(i,j)=cff*tl_zeta(i,j,idia)*tl_zeta(i,j,idia)
          END DO
# endif
        END DO
!
!  Integrate horizontally within one tile. In order to reduce the
!  round-off errors, the summation is performed in two stages. First,
!  the index j is collapsed and then the accumulation is carried out
!  along index i. In this order, the partial sums consist on much
!  fewer number of terms than in a straightforward two-dimensional
!  summation. Thus, adding numbers which are orders of magnitude
!  apart is avoided.
!
        DO i=istr,iend
          pe2d(i,jend+1)=0.0_r8
          pe2d(i,jstr-1)=0.0_r8
          ke2d(i,jstr-1)=0.0_r8
        END DO
        DO j=jstr,jend
          DO i=istr,iend
# ifdef SOLVE3D
!!          pe2d(i,Jend+1)=pe2d(i,Jend+1)+                              &
!!   &                     omn(i,j)*(z_w(i,j,N(ng))-z_w(i,j,0))
# else
!!          pe2d(i,Jend+1)=pe2d(i,Jend+1)+                              &
!!   &                     omn(i,j)*(zeta(i,j,idia)+h(i,j))
# endif
            pe2d(i,jend+1)=pe2d(i,jend+1)+omn(i,j)*h(i,j)
            pe2d(i,jstr-1)=pe2d(i,jstr-1)+omn(i,j)*pe2d(i,j)
            ke2d(i,jstr-1)=ke2d(i,jstr-1)+omn(i,j)*ke2d(i,j)
          END DO
        END DO
        my_volume=0.0_r8
        my_avgpe=0.0_r8
        my_avgke=0.0_r8
        DO i=istr,iend
          my_volume=my_volume+pe2d(i,jend+1)
          my_avgpe =my_avgpe +pe2d(i,jstr-1)
          my_avgke =my_avgke +ke2d(i,jstr-1)
        END DO
!
!  Perform global summation: whoever gets first to the critical region
!  resets global sums before global summation starts; after the global
!  summation is completed, thread, which is the last one to enter the
!  critical region, finalizes the computation of diagnostics and prints
!  them out.
!
# ifdef DISTRIBUTE
        nsub=1                           ! distributed-memory
# else
        IF (domain(ng)%SouthWest_Corner(tile).and.                      &
     &      domain(ng)%NorthEast_Corner(tile)) THEN
          nsub=1                         ! non-tiled application
        ELSE
          nsub=ntilex(ng)*ntilee(ng)     ! tiled application
        END IF
# endif
!$OMP CRITICAL (TL_DIAGNOSTICS)
        IF (tile_count.eq.0) THEN
          volume=0.0_r8
          avgke=0.0_r8
          avgpe=0.0_r8
        END IF
        volume=volume+my_volume
        avgke=avgke+my_avgke
        avgpe=avgpe+my_avgpe
        tile_count=tile_count+1
        IF (tile_count.eq.nsub) THEN
          tile_count=0
# ifdef DISTRIBUTE
          rbuffer(1)=volume
          rbuffer(2)=avgke
          rbuffer(3)=avgpe
          op_handle(1)='SUM'
          op_handle(2)='SUM'
          op_handle(3)='SUM'
          CALL mp_reduce (ng, itlm, 3, rbuffer, op_handle)
          volume=rbuffer(1)
          avgke=rbuffer(2)
          avgpe=rbuffer(3)
          trd=mymaster
# else
          trd=my_threadnum()
# endif
          avgke=avgke/volume
          avgpe=avgpe/volume
          avgkp=avgke+avgpe
!
! Report global run diagnotics values for the tangent linear kernel.
!
          IF (first_time(ng).eq.0) THEN
            first_time(ng)=1
            IF (master.and.(ng.eq.1)) THEN
              WRITE (stdout,10) 'TIME-STEP', 'YYYY-MM-DD hh:mm:ss.ss',  &
     &                          'KINETIC_ENRG', 'POTEN_ENRG',           &
# ifdef NESTING
     &                          'TOTAL_ENRG', 'NET_VOLUME', 'Grid'
# else
     &                          'TOTAL_ENRG', 'NET_VOLUME'
# endif
# ifdef NESTING
 10           FORMAT (/,1x,a,1x,a,2x,a,3x,a,4x,a,4x,a,2x,a)
# else
 10           FORMAT (/,1x,a,1x,a,2x,a,3x,a,4x,a,4x,a)
# endif
            END IF
          END IF
!
          IF (master) THEN
            WRITE (stdout,20) istep, datetime,                          &
# ifdef NESTING
     &                        avgke, avgpe, avgkp, volume, ng
# else
     &                        avgke, avgpe, avgkp, volume
# endif
# ifdef NESTING
 20         FORMAT (i10,1x,a,4(1pe14.6),2x,i2.2)
# else
 20         FORMAT (i10,1x,a,4(1pe14.6))
# endif
            FLUSH (stdout)
          END IF
!
!  If blowing-up, set exit_flag to stop computations.
!
          WRITE (kechar,'(1pe8.1)') avgke
          WRITE (pechar,'(1pe8.1)') avgpe
          DO i=1,8
            IF ((kechar(i:i).eq.'N').or.(pechar(i:i).eq.'N').or.        &
     &          (kechar(i:i).eq.'n').or.(pechar(i:i).eq.'n').or.        &
     &          (kechar(i:i).eq.'*').or.(pechar(i:i).eq.'*')) THEN
              exit_flag=1
            END IF
          END DO
        END IF
!$OMP END CRITICAL (TL_DIAGNOSTICS)
      END IF
!
      RETURN
      END SUBROUTINE tl_diag_tile
#endif
      END MODULE tl_diag_mod