/[lmdze]/trunk/Sources/dyn3d/addfi.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/addfi.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/addfi.f revision 3 by guez, Wed Feb 27 13:16:39 2008 UTC trunk/libf/dyn3d/addfi.f90 revision 71 by guez, Mon Jul 8 18:12:18 2013 UTC
# Line 1  Line 1 
1  !  module addfi_m
2  ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/addfi.F,v 1.1.1.1 2004/05/19 12:53:06 lmdzadmin Exp $  
3  !    IMPLICIT NONE
4        SUBROUTINE addfi(nq, pdt,  
5       S          pucov, pvcov, pteta, pq   , pps ,  contains
6       S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )  
7        use dimens_m    SUBROUTINE addfi(ucov, vcov, teta, q, ps, dufi, dvfi, dtetafi, dqfi, dpfi)
8        use paramet_m  
9        use comconst      ! From dyn3d/addfi.F, v 1.1.1.1 2004/05/19 12:53:06
10        use comgeom  
11        use serre      ! Addition of the physical tendencies
12        IMPLICIT NONE  
13  c      USE comconst, ONLY: dtphys
14  c=======================================================================      USE comgeom, ONLY: aire, apoln, apols
15  c      USE dimens_m, ONLY: iim, jjm, llm, nqmx
16  c    Addition of the physical tendencies  
17  c      ! First and second components of the covariant velocity:
18  c    Interface :      REAL, intent(inout):: ucov((iim + 1) * (jjm + 1), llm)
19  c    -----------      REAL, intent(inout):: vcov((iim + 1) * jjm, llm)
20  c  
21  c      Input :      REAL, intent(inout):: teta((iim + 1) * (jjm + 1), llm)
22  c      -------      ! potential temperature
23  c      pdt                    time step of integration  
24  c      pucov(ip1jmp1,llm)     first component of the covariant velocity      real, intent(inout):: q((iim + 1) * (jjm + 1), llm, nqmx)
25  c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity      real, intent(inout):: ps((iim + 1) * (jjm + 1))
26  c      pteta(ip1jmp1,llm)     potential temperature  
27  c      pts(ip1jmp1,llm)       surface temperature      ! Tendencies:
28  c      pdufi(ip1jmp1,llm)     |      REAL, intent(in):: dufi((iim + 1) * (jjm + 1), llm)
29  c      pdvfi(ip1jm,llm)       |   respective      REAL, intent(in):: dvfi((iim + 1) * jjm, llm)
30  c      pdhfi(ip1jmp1)         |      tendencies      real, intent(in):: dtetafi((iim + 1) * (jjm + 1), llm)
31  c      pdtsfi(ip1jmp1)        |      REAL, intent(in):: dqfi((iim + 1) * (jjm + 1), llm, nqmx)
32  c      REAL, intent(in):: dpfi((iim + 1) * (jjm + 1))
33  c      Output :  
34  c      --------      ! Local variables :
35  c      pucov      REAL xpn(iim), xps(iim), tpn, tps
36  c      pvcov      INTEGER j, k, iq, ij
37  c      ph      REAL, PARAMETER:: qtestw = 1e-15, qtestt = 1e-40
38  c      pts  
39  c      !-----------------------------------------------------------------------
40  c  
41  c=======================================================================      teta = teta + dtetafi * dtphys
42  c  
43  c-----------------------------------------------------------------------      DO k = 1, llm
44  c         DO ij = 1, iim
45  c    0.  Declarations :            xpn(ij) = aire(ij) * teta(ij , k)
46  c    ------------------            xps(ij) = aire(ij+(iim + 1) * jjm) * teta(ij+(iim + 1) * jjm, k)
47  c         ENDDO
48  c         tpn = SUM(xpn)/ apoln
49  c    Arguments :         tps = SUM(xps)/ apols
50  c    -----------  
51  c         DO ij = 1, iim + 1
52        INTEGER nq            teta(ij , k) = tpn
53              teta(ij+(iim + 1) * jjm, k) = tps
54        REAL pdt         ENDDO
55  c      ENDDO
56        REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)  
57        REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)      DO k = 1, llm
58  c         DO j = iim + 2, (iim + 1) * jjm
59        REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)            ucov(j, k)= ucov(j, k) + dufi(j, k) * dtphys
60        REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)         ENDDO
61  c      ENDDO
62  c    Local variables :  
63  c    -----------------      vcov = vcov + dvfi * dtphys
64  c      ps = ps + dpfi * dtphys
65        REAL xpn(iim),xps(iim),tpn,tps  
66        INTEGER j,k,iq,ij      DO iq = 1, 2
67        REAL qtestw, qtestt         DO k = 1, llm
68        PARAMETER ( qtestw = 1.0e-15 )            DO j = 1, (iim + 1) * (jjm + 1)
69        PARAMETER ( qtestt = 1.0e-40 )               q(j, k, iq)= q(j, k, iq) + dqfi(j, k, iq) * dtphys
70                 q(j, k, iq)= MAX(q(j, k, iq), qtestw)
71        REAL SSUM            ENDDO
72  c         ENDDO
73  c-----------------------------------------------------------------------      ENDDO
74    
75        !!print *, "Call sequence information: addfi"      DO iq = 3, nqmx
76           DO k = 1, llm
77        DO k = 1,llm            DO j = 1, (iim + 1) * (jjm + 1)
78           DO j = 1,ip1jmp1               q(j, k, iq)= q(j, k, iq) + dqfi(j, k, iq) * dtphys
79              pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt               q(j, k, iq)= MAX(q(j, k, iq), qtestt)
          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)  
80            ENDDO            ENDDO
81            tpn      = SSUM(iim,xpn,1)/apoln         ENDDO
82            tps      = SSUM(iim,xps,1)/apols      ENDDO
83    
84            DO ij   = 1, iip1      DO ij = 1, iim
85              pq (   ij   ,k,iq)  = tpn         xpn(ij) = aire(ij) * ps(ij)
86              pq (ij+ip1jm,k,iq)  = tps         xps(ij) = aire(ij+(iim + 1) * jjm) * ps(ij+(iim + 1) * jjm)
87        ENDDO
88        tpn = SUM(xpn)/apoln
89        tps = SUM(xps)/apols
90    
91        DO ij = 1, iim + 1
92           ps(ij) = tpn
93           ps(ij+(iim + 1) * jjm) = tps
94        ENDDO
95    
96        DO iq = 1, nqmx
97           DO k = 1, llm
98              DO ij = 1, iim
99                 xpn(ij) = aire(ij) * q(ij , k, iq)
100                 xps(ij) = aire(ij+(iim + 1) * jjm) * q(ij+(iim + 1) * jjm, k, iq)
101            ENDDO            ENDDO
102          ENDDO            tpn = SUM(xpn)/apoln
103        ENDDO            tps = SUM(xps)/apols
104    
105              DO ij = 1, iim + 1
106                 q(ij , k, iq) = tpn
107                 q(ij+(iim + 1) * jjm, k, iq) = tps
108              ENDDO
109           ENDDO
110        ENDDO
111    
112      END SUBROUTINE addfi
113    
114        RETURN  end module addfi_m
       END  
Legend:
Removed from v.3  
changed lines
  Added in v.71
  ViewVC Help
Powered by ViewVC 1.1.21