baropg.f90 File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	baropg

Function/Subroutine Documentation

baropg()

subroutine baropg

(

)

Definition at line 45 of file baropg.f90.

!==============================================================================|
   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

Here is the caller graph for this function: