bcond_ts.f90

Go to the documentation of this file.

!/===========================================================================/
! Copyright (c) 2007, The University of Massachusetts Dartmouth 
! Produced at the School of Marine Science & Technology 
! Marine Ecosystem Dynamics Modeling group
! All rights reserved.
!
! FVCOM has been developed by the joint UMASSD-WHOI research team. For 
! details of authorship and attribution of credit please see the FVCOM
! technical manual or contact the MEDM group.
!
! 
! This file is part of FVCOM. For details, see http://fvcom.smast.umassd.edu 
! The full copyright notice is contained in the file COPYRIGHT located in the 
! root directory of the FVCOM code. This original header must be maintained
! in all distributed versions.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 
! AND ANY EXPRESS OR  IMPLIED WARRANTIES, INCLUDING,  BUT NOT  LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND  FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED.  
!
!/---------------------------------------------------------------------------/
! CVS VERSION INFORMATION
! $Id$
! $Name$
! $Revision$
!/===========================================================================/

!==============================================================================|
!   Set Boundary Conditions on Temperature and Salinity                        |
!    NCON2 = 1:  SET CONDITIONS SPECIFIC TO TEMPERATURE                        |
!    NCON2 = 2:  SET CONDITIONS SPECIFIC TO SALINITY                           |
!==============================================================================|

SUBROUTINE bcond_ts(NCON2)     

  !------------------------------------------------------------------------------|
  USE all_vars
  USE bcs
  USE mod_utils
  USE mod_obcs
  USE mod_force

  IMPLICIT NONE
  REAL(SP) :: S2D,S2D_NEXT,S2D_OBC,T2D,T2D_NEXT,T2D_OBC,XFLUX2D,TMP,RAMP_TS


  INTEGER  :: I,J,K,J1,J11,J22,NCON2
  REAL(SP), ALLOCATABLE :: TTMP(:,:),STMP(:,:)

  REAL(SP) ::TMAX,TMIN,SMAX,SMIN

  !------------------------------------------------------------------------------|

  IF(dbg_set(dbg_sbr)) WRITE(ipt,*) "Start: bcond_ts"

  !
  !--SET CONDITIONS FOR FRESH WATER INFLOW---------------------------------------|
  !
  IF(river_ts_setting == 'specified') THEN
     IF(numqbc > 0) THEN
        IF(river_inflow_location == 'node') THEN
           DO i=1,numqbc
              j11=inodeq(i)
              DO k=1,kbm1
                 tf1(j11,k)=tdis(i)
                 sf1(j11,k)=sdis(i)
              END DO
           END DO
        ELSE IF(river_inflow_location == 'edge') THEN
           DO i=1,numqbc
              j11=n_icellq(i,1)
              j22=n_icellq(i,2)
              DO k=1,kbm1
                 tf1(j11,k)=tdis(i)
                 sf1(j11,k)=sdis(i)
                 tf1(j22,k)=tdis(i)
                 sf1(j22,k)=sdis(i)
              END DO
           END DO
        END IF
     END IF
  END IF


  IF(.NOT. obc_on) RETURN


  !
  !  SET TEMPERATURE CONDITIONS ON OUTER BOUNDARY
  !
  IF(ncon2 == 1) THEN

     IF(obc_temp_nudging) CALL update_obc_temp(inttime,temp_obc)

     ALLOCATE(ttmp(iobcn,kbm1));  ttmp = 0.0_sp
     DO i=1,iobcn
        j=i_obc_n(i)
        j1=next_obc(i)
        t2d=0.0_sp
        t2d_next=0.0_sp
        xflux2d=0.0_sp
        DO k=1,kbm1
           t2d=t2d+t1(j,k)*dz(j,k)
           t2d_next=t2d_next+tf1(j1,k)*dz(j1,k)
           xflux2d=xflux2d+xflux_obc(i,k)           !*DZ(J,K)
        END DO

        ! IF THE FLOW IS OUT OF THE DOMAIN
        IF(uard_obcn(i) > 0.0_sp) THEN

           tmp=xflux2d+t2d*uard_obcn(i)
           t2d_obc=(t2d*dt(j)-tmp*dti/art1(j))/d(j)

           CALL bcond_t_perturbation(t2d_next,t2d,ttmp,i,j,j1)

           DO k=1,kbm1
              tf1(j,k)=t2d_obc+ttmp(i,k)
              !           TF1(J,K)=T2D_OBC+(TF1(J1,K)-T2D_NEXT)
           END DO

           DO k=1,kbm1
              tmax = maxval(t1(nbsn(j,1:ntsn(j)),k))
              tmin = minval(t1(nbsn(j,1:ntsn(j)),k))

              IF(k == 1)THEN
                 tmax = max(tmax,(t1(j,k)*dz(j,k+1)+t1(j,k+1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k+1)))
                 tmin = min(tmin,(t1(j,k)*dz(j,k+1)+t1(j,k+1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k+1)))
              ELSE IF(k == kbm1)THEN
                 tmax = max(tmax,(t1(j,k)*dz(j,k-1)+t1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)))
                 tmin = min(tmin,(t1(j,k)*dz(j,k-1)+t1(j,k-1)*dz(j,k))/  & 
                      (dz(j,k)+dz(j,k-1)))
              ELSE
                 tmax = max(tmax,(t1(j,k)*dz(j,k-1)+t1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)),                             &
                      (t1(j,k)*dz(j,k+1)+t1(j,k+1)*dz(j,k))/           &
                      (dz(j,k)+dz(j,k+1)))
                 tmin = min(tmin,(t1(j,k)*dz(j,k-1)+t1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)),                             &
                      (t1(j,k)*dz(j,k+1)+t1(j,k+1)*dz(j,k))/           &
                      (dz(j,k)+dz(j,k+1)))
              END IF

              IF(tmin-tf1(j,k) > 0.0_sp)tf1(j,k) = tmin
              IF(tf1(j,k)-tmax > 0.0_sp)tf1(j,k) = tmax

           END DO

        else! IF THE FLOW IS INTO THE DOMAIN

           IF(obc_temp_nudging) THEN
              DO k=1,kbm1
                 tf1(j,k) = t1(j,k) - obc_temp_nudging_timescale*ramp*(t1(j,k)&
                      &-temp_obc(i,k))
              END DO
           ELSE
              DO k=1,kbm1
                 tf1(j,k) = t1(j,k)
              END DO
           END IF

        END IF

     END DO
     DEALLOCATE(ttmp)


     !
     !  SET SALINITY CONDITIONS ON OUTER BOUNDARY
     !
  ELSE IF(ncon2 == 2) THEN

     IF (obc_salt_nudging) CALL update_obc_salt(inttime,salt_obc)

     ALLOCATE(stmp(iobcn,kbm1));  stmp = 0.0_sp
     DO i=1,iobcn
        j=i_obc_n(i)
        j1=next_obc(i)
        s2d=0.0_sp
        s2d_next=0.0_sp
        xflux2d=0.0_sp
        DO k=1,kbm1
           s2d=s2d+s1(j,k)*dz(j,k)
           s2d_next=s2d_next+sf1(j1,k)*dz(j1,k)
           xflux2d=xflux2d+xflux_obc(i,k)             !*DZ(J,K)
        END DO

        ! IF THE FLOW IS OUT OF THE DOMAIN
        IF(uard_obcn(i) > 0.0_sp) THEN
           tmp=xflux2d+s2d*uard_obcn(i)
           s2d_obc=(s2d*dt(j)-tmp*dti/art1(j))/d(j)

           CALL bcond_s_perturbation(s2d_next,s2d,stmp,i,j,j1)

           DO k=1,kbm1
              sf1(j,k)=s2d_obc+stmp(i,k)  
              !           SF1(J,K)=S2D_OBC+(SF1(J1,K)-S2D_NEXT)  
           END DO

           DO k=1,kbm1
              smax = maxval(s1(nbsn(j,1:ntsn(j)),k))
              smin = minval(s1(nbsn(j,1:ntsn(j)),k))

              IF(k == 1)THEN
                 smax = max(smax,(s1(j,k)*dz(j,k+1)+s1(j,k+1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k+1)))
                 smin = min(smin,(s1(j,k)*dz(j,k+1)+s1(j,k+1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k+1)))
              ELSE IF(k == kbm1)THEN
                 smax = max(smax,(s1(j,k)*dz(j,k-1)+s1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)))
                 smin = min(smin,(s1(j,k)*dz(j,k-1)+s1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)))
              ELSE
                 smax = max(smax,(s1(j,k)*dz(j,k-1)+s1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)),                             &
                      (s1(j,k)*dz(j,k+1)+s1(j,k+1)*dz(j,k))/           &
                      (dz(j,k)+dz(j,k+1)))
                 smin = min(smin,(s1(j,k)*dz(j,k-1)+s1(j,k-1)*dz(j,k))/  &
                      (dz(j,k)+dz(j,k-1)),                             &
                      (s1(j,k)*dz(j,k+1)+s1(j,k+1)*dz(j,k))/           &
                      (dz(j,k)+dz(j,k+1)))
              END IF

              IF(smin-sf1(j,k) > 0.0_sp) sf1(j,k) = smin
              IF(sf1(j,k)-smax > 0.0_sp) sf1(j,k) = smax

           END DO
        ELSE ! IF THE FLOW IS INTO THE DOMAIN

           IF (obc_salt_nudging) THEN
              DO k=1,kbm1
                 sf1(j,k) = s1(j,k) - obc_salt_nudging_timescale*ramp*(s1(j,k)&
                      &-salt_obc(i,k))
              END DO
           ELSE
              DO k=1,kbm1
                 sf1(j,k) = s1(j,k)
              END DO
           END IF

        END IF
     END DO
     DEALLOCATE(stmp)
  ELSE
     print*, 'NCON2 NOT IN THE LIST'
     print*, 'MUST BE 1 OR 2'
     CALL pstop
  END IF



  !
  !--SET BOUNDARY CONDITIONS-----------------------------------------------------|
  !
  DO k=1,kbm1
     t(0,k)=0.0_sp
     s(0,k)=0.0_sp
  END DO

  IF(dbg_set(dbg_sbr)) WRITE(ipt,*) "End: bcond_ts"

  RETURN
END SUBROUTINE bcond_ts
!==============================================================================|