/[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 70 by guez, Mon Jun 24 15:39:52 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(nq, ucov, vcov, teta, pq, pps, dufi, dvfi, pdhfi, &
8        use paramet_m         pdqfi, pdpfi)
9        use comconst  
10        use comgeom      ! From dyn3d/addfi.F, v 1.1.1.1 2004/05/19 12:53:06
11        use serre  
12        IMPLICIT NONE      ! Addition of the physical tendencies
13  c  
14  c=======================================================================      USE comconst, ONLY: dtphys
15  c      USE comgeom, ONLY: aire, apoln, apols
16  c    Addition of the physical tendencies      USE dimens_m, ONLY: iim, llm
17  c      USE paramet_m, ONLY: iip1, iip2, ip1jm, ip1jmp1
18  c    Interface :  
19  c    -----------      INTEGER, intent(in):: nq
20  c  
21  c      Input :      REAL, intent(inout):: ucov(ip1jmp1, llm), vcov(ip1jm, llm)
22  c      -------      ! first and second components of the covariant velocity
23  c      pdt                    time step of integration  
24  c      pucov(ip1jmp1,llm)     first component of the covariant velocity      REAL, intent(inout):: teta(ip1jmp1, llm) ! potential temperature
25  c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity      real, intent(inout):: pq(ip1jmp1, llm, nq), pps(ip1jmp1)
26  c      pteta(ip1jmp1,llm)     potential temperature      REAL, intent(in):: dufi(ip1jmp1, llm), dvfi(ip1jm, llm) ! tendencies
27  c      pts(ip1jmp1,llm)       surface temperature      real, intent(in):: pdhfi(ip1jmp1, llm) ! tendency
28  c      pdufi(ip1jmp1,llm)     |      REAL, intent(in):: pdqfi(ip1jmp1, llm, nq), pdpfi(ip1jmp1)
29  c      pdvfi(ip1jm,llm)       |   respective  
30  c      pdhfi(ip1jmp1)         |      tendencies      ! Local variables :
31  c      pdtsfi(ip1jmp1)        |      REAL xpn(iim), xps(iim), tpn, tps
32  c      INTEGER j, k, iq, ij
33  c      Output :      REAL, PARAMETER:: qtestw = 1e-15, qtestt = 1e-40
34  c      --------  
35  c      pucov      !-----------------------------------------------------------------------
36  c      pvcov  
37  c      ph      DO k = 1, llm
38  c      pts         DO j = 1, ip1jmp1
39  c            teta(j, k)= teta(j, k) + pdhfi(j, k) * dtphys
40  c         ENDDO
41  c=======================================================================      ENDDO
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+ip1jm) * teta(ij+ip1jm, k)
47  c         ENDDO
48  c         tpn = SUM(xpn)/ apoln
49  c    Arguments :         tps = SUM(xps)/ apols
50  c    -----------  
51  c         DO ij = 1, iip1
52        INTEGER nq            teta(ij , k) = tpn
53              teta(ij+ip1jm, 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 = iip2, ip1jm
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    -----------------      DO k = 1, llm
64  c         DO j = 1, ip1jm
65        REAL xpn(iim),xps(iim),tpn,tps            vcov(j, k)= vcov(j, k) + dvfi(j, k) * dtphys
66        INTEGER j,k,iq,ij         ENDDO
67        REAL qtestw, qtestt      ENDDO
68        PARAMETER ( qtestw = 1.0e-15 )  
69        PARAMETER ( qtestt = 1.0e-40 )      DO j = 1, ip1jmp1
70           pps(j) = pps(j) + pdpfi(j) * dtphys
71        REAL SSUM      ENDDO
72  c  
73  c-----------------------------------------------------------------------      DO iq = 1, 2
74           DO k = 1, llm
75        !!print *, "Call sequence information: addfi"            DO j = 1, ip1jmp1
76                 pq(j, k, iq)= pq(j, k, iq) + pdqfi(j, k, iq) * dtphys
77        DO k = 1,llm               pq(j, k, iq)= MAX(pq(j, k, iq), qtestw)
          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)  
78            ENDDO            ENDDO
79            tpn      = SSUM(iim,xpn,1)/apoln         ENDDO
80            tps      = SSUM(iim,xps,1)/apols      ENDDO
81    
82            DO ij   = 1, iip1      DO iq = 3, nq
83              pq (   ij   ,k,iq)  = tpn         DO k = 1, llm
84              pq (ij+ip1jm,k,iq)  = tps            DO j = 1, ip1jmp1
85                 pq(j, k, iq)= pq(j, k, iq) + pdqfi(j, k, iq) * dtphys
86                 pq(j, k, iq)= MAX(pq(j, k, iq), qtestt)
87            ENDDO            ENDDO
88          ENDDO         ENDDO
89        ENDDO      ENDDO
90    
91        DO ij = 1, iim
92           xpn(ij) = aire(ij) * pps(ij)
93           xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm)
94        ENDDO
95        tpn = SUM(xpn)/apoln
96        tps = SUM(xps)/apols
97    
98        DO ij = 1, iip1
99           pps (ij) = tpn
100           pps (ij+ip1jm) = tps
101        ENDDO
102    
103        DO iq = 1, nq
104           DO k = 1, llm
105              DO ij = 1, iim
106                 xpn(ij) = aire(ij) * pq(ij , k, iq)
107                 xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm, k, iq)
108              ENDDO
109              tpn = SUM(xpn)/apoln
110              tps = SUM(xps)/apols
111    
112              DO ij = 1, iip1
113                 pq (ij , k, iq) = tpn
114                 pq (ij+ip1jm, k, iq) = tps
115              ENDDO
116           ENDDO
117        ENDDO
118    
119      END SUBROUTINE addfi
120    
121        RETURN  end module addfi_m
       END  
Legend:
Removed from v.3  
changed lines
  Added in v.70
  ViewVC Help
Powered by ViewVC 1.1.21