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

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

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

revision 68 by guez, Wed Nov 14 16:59:30 2012 UTC revision 69 by guez, Mon Feb 18 16:33:12 2013 UTC
# Line 1  Line 1 
1  SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, time_step, itau)  module fluxstokenc_m
2    
3    ! Author: F. Hourdin    IMPLICIT NONE
4    
5    USE histwrite_m, ONLY : histwrite  contains
   USE dimens_m, ONLY : jjm, llm, nqmx  
   USE paramet_m, ONLY : iip1, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1  
   USE comgeom, ONLY : aire  
   USE tracstoke, ONLY : istdyn, istphy  
6    
7    IMPLICIT NONE    SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, time_step, itau)
8    
9        ! Author: F. Hourdin
10    
11        USE histwrite_m, ONLY: histwrite
12        USE dimens_m, ONLY: jjm, llm, nqmx
13        USE paramet_m, ONLY: iip1, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1
14        USE comgeom, ONLY: aire
15        USE tracstoke, ONLY: istdyn, istphy
16    
17        REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
18        REAL masse(ip1jmp1, llm)
19        real, intent(in):: phi(ip1jmp1, llm)
20        real, intent(in):: teta(ip1jmp1, llm)
21        REAL, intent(in):: phis(ip1jmp1)
22        REAL, intent(in):: time_step
23        INTEGER, INTENT (IN):: itau
24    
25        ! Variables local to the procedure:
26    
27        REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
28        REAL, SAVE:: massem(ip1jmp1, llm)
29        real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
30    
31        REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
32        REAL tst(1), ist(1), istp(1)
33        INTEGER ij, l
34        INTEGER, save:: fluxid, fluxvid
35        integer fluxdid
36    
37        !-------------------------------------------------------------
38    
39        IF (itau == 0) THEN
40           CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &
41                fluxid, fluxvid, fluxdid)
42           CALL histwrite(fluxid, 'phis', 1, phis)
43           CALL histwrite(fluxid, 'aire', 1, aire)
44           tst(1) = time_step
45           CALL histwrite(fluxdid, 'dtvr', 1, tst)
46           ist(1) = istdyn
47           CALL histwrite(fluxdid, 'istdyn', 1, ist)
48           istp(1) = istphy
49           CALL histwrite(fluxdid, 'istphy', 1, istp)
50    
51           CALL initial0(ijp1llm, phic)
52           CALL initial0(ijp1llm, tetac)
53           CALL initial0(ijp1llm, pbaruc)
54           CALL initial0(ijmllm, pbarvc)
55        END IF
56    
57        !   accumulation des flux de masse horizontaux
58        DO l = 1, llm
59           DO ij = 1, ip1jmp1
60              pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
61              tetac(ij, l) = tetac(ij, l) + teta(ij, l)
62              phic(ij, l) = phic(ij, l) + phi(ij, l)
63           END DO
64           DO ij = 1, ip1jm
65              pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
66           END DO
67        END DO
68    
69        !   selection de la masse instantannee des mailles avant le transport.
70        IF (itau == 0) THEN
71           CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)
72        END IF
73    
74        IF (mod(itau + 1, istdyn) == 0) THEN
75           ! on advecte a ce pas de temps
76           !    normalisation
77           DO l = 1, llm
78              DO ij = 1, ip1jmp1
79                 pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)
80                 tetac(ij, l) = tetac(ij, l)/float(istdyn)
81                 phic(ij, l) = phic(ij, l)/float(istdyn)
82              END DO
83              DO ij = 1, ip1jm
84                 pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
85              END DO
86           END DO
87    
88           !   traitement des flux de masse avant advection.
89           !     1. calcul de w
90           !     2. groupement des mailles pres du pole.
91    
92           CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
93    
94           CALL histwrite(fluxid, 'masse', itau, massem)
95           CALL histwrite(fluxid, 'pbaru', itau, pbarug)
96           CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)
97           CALL histwrite(fluxid, 'w', itau, wg)
98           CALL histwrite(fluxid, 'teta', itau, tetac)
99           CALL histwrite(fluxid, 'phi', itau, phic)
100        END IF
101    
102    REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)    END SUBROUTINE fluxstokenc
   REAL masse(ip1jmp1, llm)  
   real, intent(in):: phi(ip1jmp1, llm)  
   real, intent(in):: teta(ip1jmp1, llm)  
   REAL phis(ip1jmp1)  
   REAL, intent(in):: time_step  
   INTEGER, INTENT (IN) :: itau  
   
   ! Variables local to the procedure:  
   
   REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)  
   REAL, SAVE:: massem(ip1jmp1, llm)  
   real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)  
   
   REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)  
   REAL tst(1), ist(1), istp(1)  
   INTEGER ij, l  
   INTEGER, save:: fluxid, fluxvid  
   integer fluxdid  
   
   !-------------------------------------------------------------  
   
   IF (itau == 0) THEN  
      CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &  
           fluxid, fluxvid, fluxdid)  
      CALL histwrite(fluxid, 'phis', 1, phis)  
      CALL histwrite(fluxid, 'aire', 1, aire)  
      tst(1) = time_step  
      CALL histwrite(fluxdid, 'dtvr', 1, tst)  
      ist(1) = istdyn  
      CALL histwrite(fluxdid, 'istdyn', 1, ist)  
      istp(1) = istphy  
      CALL histwrite(fluxdid, 'istphy', 1, istp)  
   
      CALL initial0(ijp1llm, phic)  
      CALL initial0(ijp1llm, tetac)  
      CALL initial0(ijp1llm, pbaruc)  
      CALL initial0(ijmllm, pbarvc)  
   END IF  
   
   !   accumulation des flux de masse horizontaux  
   DO l = 1, llm  
      DO ij = 1, ip1jmp1  
         pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)  
         tetac(ij, l) = tetac(ij, l) + teta(ij, l)  
         phic(ij, l) = phic(ij, l) + phi(ij, l)  
      END DO  
      DO ij = 1, ip1jm  
         pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)  
      END DO  
   END DO  
   
   !   selection de la masse instantannee des mailles avant le transport.  
   IF (itau == 0) THEN  
      CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)  
   END IF  
   
   IF (mod(itau + 1, istdyn) == 0) THEN  
      ! on advecte a ce pas de temps  
      !    normalisation  
      DO l = 1, llm  
         DO ij = 1, ip1jmp1  
            pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)  
            tetac(ij, l) = tetac(ij, l)/float(istdyn)  
            phic(ij, l) = phic(ij, l)/float(istdyn)  
         END DO  
         DO ij = 1, ip1jm  
            pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)  
         END DO  
      END DO  
   
      !   traitement des flux de masse avant advection.  
      !     1. calcul de w  
      !     2. groupement des mailles pres du pole.  
   
      CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)  
   
      CALL histwrite(fluxid, 'masse', itau, massem)  
      CALL histwrite(fluxid, 'pbaru', itau, pbarug)  
      CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)  
      CALL histwrite(fluxid, 'w', itau, wg)  
      CALL histwrite(fluxid, 'teta', itau, tetac)  
      CALL histwrite(fluxid, 'phi', itau, phic)  
   END IF                                  
103    
104  END SUBROUTINE fluxstokenc  end module fluxstokenc_m
Legend:
Removed from v.68  
changed lines
  Added in v.69
  ViewVC Help
Powered by ViewVC 1.1.21