/[lmdze]/trunk/libf/dyn3d/addfi.f90
ViewVC logotype

Diff of /trunk/libf/dyn3d/addfi.f90

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 44 by guez, Wed Apr 13 12:29:18 2011 UTC
# Line 1  Line 1 
1  !  module addfi_m
 ! $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  
2    
3        DO  k    = 1, llm    IMPLICIT NONE
4    
5    contains
6    
7      SUBROUTINE addfi(nq, pdt, pucov, pvcov, teta, pq, pps, pdufi, pdvfi, pdhfi,&
8           pdqfi, pdpfi)
9    
10        ! From dyn3d/addfi.F,v 1.1.1.1 2004/05/19 12:53:06
11    
12        !    Addition of the physical tendencies
13    
14        !    Interface :
15    
16        !      Input :
17    
18        !      pdt                    time step of integration
19        !      pucov(ip1jmp1,llm)     first component of the covariant velocity
20        !      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
21        !      teta(ip1jmp1,llm)     potential temperature
22        !      pts(ip1jmp1,llm)       surface temperature
23        !      pdufi(ip1jmp1,llm)     |
24        !      pdvfi(ip1jm,llm)       |   respective
25        !      pdhfi(ip1jmp1)         |      tendencies
26        !      pdtsfi(ip1jmp1)        |
27    
28        !      Output :
29    
30        !      pucov
31        !      pvcov
32        !      ph
33        !      pts
34    
35        use dimens_m
36        use paramet_m
37        use comconst
38        use comgeom
39        use serre
40    
41        !    Arguments :
42    
43        INTEGER nq
44    
45        REAL pdt
46    
47        REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
48        REAL, intent(inout):: teta(ip1jmp1,llm)
49        real pq(ip1jmp1,llm,nq),pps(ip1jmp1)
50    
51        REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
52        REAL pdqfi(ip1jmp1,llm,nq), pdpfi(ip1jmp1)
53        real, intent(in):: pdhfi(ip1jmp1,llm)
54    
55        !    Local variables :
56    
57        REAL xpn(iim),xps(iim),tpn,tps
58        INTEGER j,k,iq,ij
59        REAL qtestw, qtestt
60        PARAMETER ( qtestw = 1.0e-15 )
61        PARAMETER ( qtestt = 1.0e-40 )
62    
63        REAL SSUM
64    
65        !-----------------------------------------------------------------------
66    
67        DO k = 1,llm
68           DO j = 1,ip1jmp1
69              teta(j,k)= teta(j,k) + pdhfi(j,k) * pdt
70           ENDDO
71        ENDDO
72    
73        DO  k    = 1, llm
74         DO  ij   = 1, iim         DO  ij   = 1, iim
75           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)            xpn(ij) = aire(   ij   ) * teta(  ij    ,k)
76           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)            xps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,k)
77         ENDDO         ENDDO
78         tpn      = SSUM(iim,xpn,1)/ apoln         tpn      = SSUM(iim,xpn,1)/ apoln
79         tps      = SSUM(iim,xps,1)/ apols         tps      = SSUM(iim,xps,1)/ apols
80    
81         DO ij   = 1, iip1         DO ij   = 1, iip1
82           pteta(   ij   ,k)  = tpn            teta(   ij   ,k)  = tpn
83           pteta(ij+ip1jm,k)  = tps            teta(ij+ip1jm,k)  = tps
84           ENDDO
85        ENDDO
86    
87        DO k = 1,llm
88           DO j = iip2,ip1jm
89              pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
90           ENDDO
91        ENDDO
92    
93        DO k = 1,llm
94           DO j = 1,ip1jm
95              pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
96           ENDDO
97        ENDDO
98    
99        DO j = 1,ip1jmp1
100           pps(j) = pps(j) + pdpfi(j) * pdt
101        ENDDO
102    
103        DO iq = 1, 2
104           DO k = 1,llm
105              DO j = 1,ip1jmp1
106                 pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
107                 pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
108              ENDDO
109         ENDDO         ENDDO
110        ENDDO      ENDDO
 c  
111    
112        DO k = 1,llm      DO iq = 3, nq
113           DO j = iip2,ip1jm         DO k = 1,llm
114              pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt            DO j = 1,ip1jmp1
115           ENDDO               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
116        ENDDO               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
117              ENDDO
118        DO k = 1,llm         ENDDO
119           DO j = 1,ip1jm      ENDDO
             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  
120    
121        DO  ij   = 1, iim
122           xpn(ij) = aire(   ij   ) * pps(  ij     )
123           xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
124        ENDDO
125        tpn      = SSUM(iim,xpn,1)/apoln
126        tps      = SSUM(iim,xps,1)/apols
127    
128        DO ij   = 1, iip1
129           pps (   ij     )  = tpn
130           pps ( ij+ip1jm )  = tps
131        ENDDO
132    
133        DO iq = 1, nq      DO iq = 1, nq
134          DO  k    = 1, llm         DO  k    = 1, llm
135            DO  ij   = 1, iim            DO  ij   = 1, iim
136              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)               xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
137              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)               xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
138            ENDDO            ENDDO
139            tpn      = SSUM(iim,xpn,1)/apoln            tpn      = SSUM(iim,xpn,1)/apoln
140            tps      = SSUM(iim,xps,1)/apols            tps      = SSUM(iim,xps,1)/apols
141    
142            DO ij   = 1, iip1            DO ij   = 1, iip1
143              pq (   ij   ,k,iq)  = tpn               pq (   ij   ,k,iq)  = tpn
144              pq (ij+ip1jm,k,iq)  = tps               pq (ij+ip1jm,k,iq)  = tps
145            ENDDO            ENDDO
146          ENDDO         ENDDO
147        ENDDO      ENDDO
148    
149      END SUBROUTINE addfi
150    
151        RETURN  end module addfi_m
       END  
Legend:
Removed from v.3  
changed lines
  Added in v.44
  ViewVC Help
Powered by ViewVC 1.1.21