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

Diff of /trunk/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 37 by guez, Tue Dec 21 15:45:48 2010 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, pteta, 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        !      pteta(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 pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)
49    
50        REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
51        REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
52    
53        !    Local variables :
54    
55        REAL xpn(iim),xps(iim),tpn,tps
56        INTEGER j,k,iq,ij
57        REAL qtestw, qtestt
58        PARAMETER ( qtestw = 1.0e-15 )
59        PARAMETER ( qtestt = 1.0e-40 )
60    
61        REAL SSUM
62    
63        !-----------------------------------------------------------------------
64    
65        DO k = 1,llm
66           DO j = 1,ip1jmp1
67              pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
68           ENDDO
69        ENDDO
70    
71        DO  k    = 1, llm
72         DO  ij   = 1, iim         DO  ij   = 1, iim
73           xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)            xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
74           xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)            xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
75         ENDDO         ENDDO
76         tpn      = SSUM(iim,xpn,1)/ apoln         tpn      = SSUM(iim,xpn,1)/ apoln
77         tps      = SSUM(iim,xps,1)/ apols         tps      = SSUM(iim,xps,1)/ apols
78    
79         DO ij   = 1, iip1         DO ij   = 1, iip1
80           pteta(   ij   ,k)  = tpn            pteta(   ij   ,k)  = tpn
81           pteta(ij+ip1jm,k)  = tps            pteta(ij+ip1jm,k)  = tps
82           ENDDO
83        ENDDO
84    
85        DO k = 1,llm
86           DO j = iip2,ip1jm
87              pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
88           ENDDO
89        ENDDO
90    
91        DO k = 1,llm
92           DO j = 1,ip1jm
93              pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
94           ENDDO
95        ENDDO
96    
97        DO j = 1,ip1jmp1
98           pps(j) = pps(j) + pdpfi(j) * pdt
99        ENDDO
100    
101        DO iq = 1, 2
102           DO k = 1,llm
103              DO j = 1,ip1jmp1
104                 pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
105                 pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
106              ENDDO
107         ENDDO         ENDDO
108        ENDDO      ENDDO
 c  
109    
110        DO k = 1,llm      DO iq = 3, nq
111           DO j = iip2,ip1jm         DO k = 1,llm
112              pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt            DO j = 1,ip1jmp1
113           ENDDO               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
114        ENDDO               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
115              ENDDO
116        DO k = 1,llm         ENDDO
117           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  
118    
119        DO  ij   = 1, iim
120           xpn(ij) = aire(   ij   ) * pps(  ij     )
121           xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
122        ENDDO
123        tpn      = SSUM(iim,xpn,1)/apoln
124        tps      = SSUM(iim,xps,1)/apols
125    
126        DO ij   = 1, iip1
127           pps (   ij     )  = tpn
128           pps ( ij+ip1jm )  = tps
129        ENDDO
130    
131        DO iq = 1, nq      DO iq = 1, nq
132          DO  k    = 1, llm         DO  k    = 1, llm
133            DO  ij   = 1, iim            DO  ij   = 1, iim
134              xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)               xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
135              xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)               xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
136            ENDDO            ENDDO
137            tpn      = SSUM(iim,xpn,1)/apoln            tpn      = SSUM(iim,xpn,1)/apoln
138            tps      = SSUM(iim,xps,1)/apols            tps      = SSUM(iim,xps,1)/apols
139    
140            DO ij   = 1, iip1            DO ij   = 1, iip1
141              pq (   ij   ,k,iq)  = tpn               pq (   ij   ,k,iq)  = tpn
142              pq (ij+ip1jm,k,iq)  = tps               pq (ij+ip1jm,k,iq)  = tps
143            ENDDO            ENDDO
144          ENDDO         ENDDO
145        ENDDO      ENDDO
146    
147      END SUBROUTINE addfi
148    
149        RETURN  end module addfi_m
       END  
Legend:
Removed from v.3  
changed lines
  Added in v.37
  ViewVC Help
Powered by ViewVC 1.1.21