baropg.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$
!/===========================================================================/

!==============================================================================|
!     CALCULATE THE BAROCLINIC PRESSURE GRADIENT IN SIGMA COORDINATES          |
!==============================================================================|

   SUBROUTINE baropg 

!==============================================================================|
   USE all_vars
   USE mod_spherical
   USE mod_northpole
   USE mod_wd

   IMPLICIT NONE
   REAL(SP) :: RIJK(0:N,3,KBM1), DRIJK1(0:N,3,KBM1), DRIJK2(0:N,KBM1)
   REAL(SP) :: TEMP,DIJ,DRHO1,DRHO2
   INTEGER  :: I,K,J,J1,J2,IJK
!==============================================================================|

   IF(dbg_set(dbg_sbr)) WRITE(ipt,*) "Start: baropg.F"
   
   ! USE RAMP CALCULATED IN 'internal_step.F'

!----------SUBTRACT MEAN DENSITY TO MINIMIZE ROUNDOFF ERROR--------------------!

   rho1(:,1:kbm1) = rho1(:,1:kbm1) - rmean1(:,1:kbm1)
   rho = rho - rmean 

!----------INITIALIZE ARRAYS---------------------------------------------------!

   drhox      = 0.0_sp
   drhoy      = 0.0_sp
   rmean(0,:) = 0.0_sp
   rho(0,:)   = 0.0_sp
   rijk       = 0.0_sp
   drijk1     = 0.0_sp
   drijk2     = 0.0_sp

!----------CALCULATE AVERAGE DENSITY ON EACH EDGE------------------------------!

   DO k=1,kbm1
     DO i=1,n
       DO j=1,3
         j1=j+1-int((j+1)/4)*3
         j2=j+2-int((j+2)/4)*3
         rijk(i,j,k)  = 0.5_sp*(rho1(nv(i,j1),k)+rho1(nv(i,j2),k))
       END DO
     END DO
   END DO

   DO i=1,n
     DO j=1,3
       drijk1(i,j,1)=rijk(i,j,1)*(-zz1(i,1))
       DO k=2,kbm1
         drijk1(i,j,k)=0.5_sp*(rijk(i,j,k-1)+rijk(i,j,k))*(zz1(i,k-1)-zz1(i,k))
         drijk1(i,j,k)=drijk1(i,j,k)+drijk1(i,j,k-1)
       END DO
     END DO
   END DO

   DO i=1,n
     drijk2(i,1)=0.0_sp
     DO k=2,kbm1
       drijk2(i,k)=0.5_sp*(zz1(i,k-1)+zz1(i,k))*(rho(i,k)-rho(i,k-1)) 
       drijk2(i,k)=drijk2(i,k-1)+drijk2(i,k)
     END DO
   END DO

   DO i = 1, n
    IF(iswetct(i)*iswetc(i) == 1 .AND. &
      (h(nv(i,1)) > static_ssh_adj .OR. h(nv(i,2)) > static_ssh_adj .OR. h(nv(i,3)) > static_ssh_adj))THEN
     DO k=1,kbm1
        DO j = 1, 3
          j1=j+1-int((j+1)/4)*3
          j2=j+2-int((j+2)/4)*3
          ijk=nbe(i,j)
          dij=0.5_sp*(dt(nv(i,j1))+dt(nv(i,j2)))

          drho1=(vy(nv(i,j1))-vy(nv(i,j2)))*drijk1(i,j,k)*dt1(i)
          drho2=(vy(nv(i,j1))-vy(nv(i,j2)))*dij*drijk2(i,k)
          drhox(i,k)=drhox(i,k)+drho1+drho2

      drho1=(vx(nv(i,j2))-vx(nv(i,j1)))*drijk1(i,j,k)*dt1(i)
          drho2=(vx(nv(i,j2))-vx(nv(i,j1)))*dij*drijk2(i,k)
          drhoy(i,k)=drhoy(i,k)+drho1+drho2

       END DO
     END DO
    END IF
   END DO



!----------MULTIPLY BY GRAVITY AND ELEMENT DEPTH-------------------------------!

   DO k=1,kbm1
     drhox(:,k)=drhox(:,k)*dt1(:)*dz1(:,k)*grav_e(:)*ramp
     drhoy(:,k)=drhoy(:,k)*dt1(:)*dz1(:,k)*grav_e(:)*ramp
   END DO

!----------ADD MEAN DENSITY BACK ON--------------------------------------------!

   rho1 = rho1 + rmean1
   rho  = rho  + rmean

   IF(dbg_set(dbg_sbr)) WRITE(ipt,*) "End: baropg.F"

   RETURN
   END SUBROUTINE baropg
!==============================================================================|