--- trunk/libf/dyn3d/addfi.f 2008/02/27 13:16:39 3 +++ trunk/libf/dyn3d/addfi.f90 2013/07/08 18:12:18 71 @@ -1,164 +1,114 @@ -! -! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/addfi.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $ -! - SUBROUTINE addfi(nq, pdt, - S pucov, pvcov, pteta, pq , pps , - S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) - use dimens_m - use paramet_m - use comconst - use comgeom - use serre - IMPLICIT NONE -c -c======================================================================= -c -c Addition of the physical tendencies -c -c Interface : -c ----------- -c -c Input : -c ------- -c pdt time step of integration -c pucov(ip1jmp1,llm) first component of the covariant velocity -c pvcov(ip1ip1jm,llm) second component of the covariant velocity -c pteta(ip1jmp1,llm) potential temperature -c pts(ip1jmp1,llm) surface temperature -c pdufi(ip1jmp1,llm) | -c pdvfi(ip1jm,llm) | respective -c pdhfi(ip1jmp1) | tendencies -c pdtsfi(ip1jmp1) | -c -c Output : -c -------- -c pucov -c pvcov -c ph -c pts -c -c -c======================================================================= -c -c----------------------------------------------------------------------- -c -c 0. Declarations : -c ------------------ -c -c -c Arguments : -c ----------- -c - INTEGER nq - - REAL pdt -c - REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) - REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1) -c - REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) - REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1) -c -c Local variables : -c ----------------- -c - REAL xpn(iim),xps(iim),tpn,tps - INTEGER j,k,iq,ij - REAL qtestw, qtestt - PARAMETER ( qtestw = 1.0e-15 ) - PARAMETER ( qtestt = 1.0e-40 ) - - REAL SSUM -c -c----------------------------------------------------------------------- - - !!print *, "Call sequence information: addfi" - - DO k = 1,llm - DO j = 1,ip1jmp1 - pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt - ENDDO - ENDDO - - DO k = 1, llm - DO ij = 1, iim - xpn(ij) = aire( ij ) * pteta( ij ,k) - xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) - ENDDO - tpn = SSUM(iim,xpn,1)/ apoln - tps = SSUM(iim,xps,1)/ apols - - DO ij = 1, iip1 - pteta( ij ,k) = tpn - pteta(ij+ip1jm,k) = tps - ENDDO - ENDDO -c - - DO k = 1,llm - DO j = iip2,ip1jm - pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt - ENDDO - ENDDO - - DO k = 1,llm - DO j = 1,ip1jm - pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt - ENDDO - ENDDO - -c - DO j = 1,ip1jmp1 - pps(j) = pps(j) + pdpfi(j) * pdt - ENDDO - - DO iq = 1, 2 - DO k = 1,llm - DO j = 1,ip1jmp1 - pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt - pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) - ENDDO - ENDDO - ENDDO - - DO iq = 3, nq - DO k = 1,llm - DO j = 1,ip1jmp1 - pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt - pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) - ENDDO - ENDDO - ENDDO - - - DO ij = 1, iim - xpn(ij) = aire( ij ) * pps( ij ) - xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) - ENDDO - tpn = SSUM(iim,xpn,1)/apoln - tps = SSUM(iim,xps,1)/apols - - DO ij = 1, iip1 - pps ( ij ) = tpn - pps ( ij+ip1jm ) = tps - ENDDO - - - DO iq = 1, nq - DO k = 1, llm - DO ij = 1, iim - xpn(ij) = aire( ij ) * pq( ij ,k,iq) - xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) +module addfi_m + + IMPLICIT NONE + +contains + + SUBROUTINE addfi(ucov, vcov, teta, q, ps, dufi, dvfi, dtetafi, dqfi, dpfi) + + ! From dyn3d/addfi.F, v 1.1.1.1 2004/05/19 12:53:06 + + ! Addition of the physical tendencies + + USE comconst, ONLY: dtphys + USE comgeom, ONLY: aire, apoln, apols + USE dimens_m, ONLY: iim, jjm, llm, nqmx + + ! First and second components of the covariant velocity: + REAL, intent(inout):: ucov((iim + 1) * (jjm + 1), llm) + REAL, intent(inout):: vcov((iim + 1) * jjm, llm) + + REAL, intent(inout):: teta((iim + 1) * (jjm + 1), llm) + ! potential temperature + + real, intent(inout):: q((iim + 1) * (jjm + 1), llm, nqmx) + real, intent(inout):: ps((iim + 1) * (jjm + 1)) + + ! Tendencies: + REAL, intent(in):: dufi((iim + 1) * (jjm + 1), llm) + REAL, intent(in):: dvfi((iim + 1) * jjm, llm) + real, intent(in):: dtetafi((iim + 1) * (jjm + 1), llm) + REAL, intent(in):: dqfi((iim + 1) * (jjm + 1), llm, nqmx) + REAL, intent(in):: dpfi((iim + 1) * (jjm + 1)) + + ! Local variables : + REAL xpn(iim), xps(iim), tpn, tps + INTEGER j, k, iq, ij + REAL, PARAMETER:: qtestw = 1e-15, qtestt = 1e-40 + + !----------------------------------------------------------------------- + + teta = teta + dtetafi * dtphys + + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire(ij) * teta(ij , k) + xps(ij) = aire(ij+(iim + 1) * jjm) * teta(ij+(iim + 1) * jjm, k) + ENDDO + tpn = SUM(xpn)/ apoln + tps = SUM(xps)/ apols + + DO ij = 1, iim + 1 + teta(ij , k) = tpn + teta(ij+(iim + 1) * jjm, k) = tps + ENDDO + ENDDO + + DO k = 1, llm + DO j = iim + 2, (iim + 1) * jjm + ucov(j, k)= ucov(j, k) + dufi(j, k) * dtphys + ENDDO + ENDDO + + vcov = vcov + dvfi * dtphys + ps = ps + dpfi * dtphys + + DO iq = 1, 2 + DO k = 1, llm + DO j = 1, (iim + 1) * (jjm + 1) + q(j, k, iq)= q(j, k, iq) + dqfi(j, k, iq) * dtphys + q(j, k, iq)= MAX(q(j, k, iq), qtestw) + ENDDO + ENDDO + ENDDO + + DO iq = 3, nqmx + DO k = 1, llm + DO j = 1, (iim + 1) * (jjm + 1) + q(j, k, iq)= q(j, k, iq) + dqfi(j, k, iq) * dtphys + q(j, k, iq)= MAX(q(j, k, iq), qtestt) ENDDO - tpn = SSUM(iim,xpn,1)/apoln - tps = SSUM(iim,xps,1)/apols + ENDDO + ENDDO - DO ij = 1, iip1 - pq ( ij ,k,iq) = tpn - pq (ij+ip1jm,k,iq) = tps + DO ij = 1, iim + xpn(ij) = aire(ij) * ps(ij) + xps(ij) = aire(ij+(iim + 1) * jjm) * ps(ij+(iim + 1) * jjm) + ENDDO + tpn = SUM(xpn)/apoln + tps = SUM(xps)/apols + + DO ij = 1, iim + 1 + ps(ij) = tpn + ps(ij+(iim + 1) * jjm) = tps + ENDDO + + DO iq = 1, nqmx + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire(ij) * q(ij , k, iq) + xps(ij) = aire(ij+(iim + 1) * jjm) * q(ij+(iim + 1) * jjm, k, iq) ENDDO - ENDDO - ENDDO + tpn = SUM(xpn)/apoln + tps = SUM(xps)/apols + + DO ij = 1, iim + 1 + q(ij , k, iq) = tpn + q(ij+(iim + 1) * jjm, k, iq) = tps + ENDDO + ENDDO + ENDDO + + END SUBROUTINE addfi - RETURN - END +end module addfi_m