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

!==============================================================================|
SUBROUTINE rho_pmean
  !==============================================================================|
  USE all_vars
  USE mod_utils
  USE mod_par
  USE sinter
  USE mod_wd
  IMPLICIT NONE

  INTEGER, PARAMETER :: KBB=601
  INTEGER, PARAMETER :: KBBM1=kbb-1

  REAL(SP) DELTZ
  REAL(SP), DIMENSION(KBB)   :: PHY_Z   !Depth(m) in every standary Z levels 
  REAL(SP), DIMENSION(KBB)   :: RHOZ    !density in standary Z levels 

  REAL(SP), DIMENSION(KBB)   :: RHOA    !density mean in standary Z levals

  REAL(SP), DIMENSION(KBM1)  :: ZM      !Depth (m) in every sigma levels for giving node
  REAL(SP), DIMENSION(KBM1)  :: RHOS      !DENS AT SIGMA LEVELS

  REAL(SP), DIMENSION(KBB)   :: FCOUNT

  INTEGER :: I,K,status,IERR,IB
  REAL(SP) :: Z_TOP, Z_BOTTOM,SBUF

  !========================================
  ! ONLY USED FOR PAR
  REAL(SP), DIMENSION(KBB,NPROCS) :: RHOA_RCV, FCOUNT_RCV
  !========================================

  !--CALCULATE Z-LEVELS TO MAX DEPTH---------------------------------------------|

  IF(dbg_set(dbg_sbr)) WRITE(ipt,*) "START: RHO_PMEAN"

  IF(dbg_set(dbg_log)) WRITE(ipt,*) "! Recalculating mean density in pressure coordinates"


  IF(serial) THEN
     IF(wetting_drying_on)THEN
       z_top = maxval(el(1:m)*iswetn(1:m))
     ELSE
       z_top = maxval(el(1:m))
     END IF
     z_bottom = hmax+spacing(hmax)
  ELSE
  END IF


!  DELTZ=HMAX/FLOAT(KBBM1)
  deltz=(z_bottom + z_top)/float(kbbm1)

  DO k=1,kbb
     phy_z(k)= z_top - float(k-1)*deltz
  END DO

!  PHY_Z(1)=PHY_Z(1)-spacing(PHY_Z(1))
!  PHY_Z(KBB)=PHY_Z(KBB)+spacing(PHY_Z(KBB))

  phy_z(1)=nearest(z_top,-1.0_sp) ! Nearest number smaller than Z_TOP

  phy_z(kbb)=nearest(-z_bottom,1.0_sp) ! Nearest number larger than Z_BOTTOM

  
  !--DO THE AVERAGE OVER Z_levels 


  IF(serial) THEN
     rhoa=0.0_sp
     fcount=0.0_sp
     DO i=1,m

        !--LINEARLY INTERPOLATE TO OBTAIN DENSITY VALUES AT Z LEVELS-------------------|
        zm(1:kbm1)=zz(i,1:kbm1)*d(i)+el(i)
        rhos = rho1(i,1:kbm1)
        CALL sinter_extrp_none(zm,rhos,phy_z,rhoz,kbm1,kbb)

        !--SUM THE DENSITY ACROSS ALL THE NODES AT ZLEVELS ----------!
        DO k=1,kbb       
           IF(-h(i).LE.phy_z(k) .AND. el(i) .GE. phy_z(k)) THEN
              fcount(k) = fcount(k) + 1.0_sp
              rhoa(k)=rhoa(k)+rhoz(k)
           END IF

        END DO

     END DO
        
     ! TAKE THE AVERAGE
     IF(minval(fcount) .LT. 1.0_sp)THEN
        IF(dbg_set(dbg_log)) WRITE(ipt,*) "FOUND NO DATA AT DEPTH:",phy_z(minloc(fcount,1))
        CALL fatal_error("RHO_PMEAN: In Serial case, found fcount LT 0.0!")
     END IF
     rhoa = rhoa / fcount

  ELSE

  END IF


  !--LINEARLY INTERPOLATE TO OBTAIN DENSITY VALUES AT SIGMA LEVELS-------------------|


  DO i=1,m
     IF(wetting_drying_on.and.iswetn(i)==0)cycle
     DO k=1,kbm1
        zm(k)=zz(i,k)*d(i)+el(i)
     END DO
     CALL sinter_extrp_none(phy_z,rhoa,zm,rhos,kbb,kbm1)
     rmean1(i,1:kbm1) = rhos
  END DO

  rmean1(:,kb)=0.0_sp


  CALL n2e3d(rmean1,rmean)


  IF(dbg_set(dbg_sbr)) WRITE(ipt,*) "END: RHO_PMEAN"

  RETURN
END SUBROUTINE rho_pmean