/[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 30 by guez, Thu Apr 1 09:07:28 2010 UTC revision 31 by guez, Thu Apr 1 14:59:19 2010 UTC
# Line 1  Line 1 
1  SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,time_step,itau)  SUBROUTINE fluxstokenc(pbaru, pbarv, masse, teta, phi, phis, time_step, itau)
2    
3    !     Auteur :  F. Hourdin    ! Author: F. Hourdin
4    
5    USE histwrite_m    USE histwrite_m, ONLY : histwrite
6    USE dimens_m    USE dimens_m, ONLY : jjm, llm, nqmx
7    USE paramet_m    USE paramet_m, ONLY : iip1, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1
8    USE comconst    USE comgeom, ONLY : aire
9    USE comvert    USE tracstoke, ONLY : istdyn, istphy
   USE comgeom  
   USE temps  
   USE tracstoke  
10    
11    IMPLICIT NONE    IMPLICIT NONE
12    
13    REAL, intent(in):: time_step    REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
14    real t_wrt, t_ops    REAL masse(ip1jmp1, llm), teta(ip1jmp1, llm), phi(ip1jmp1, llm)
   REAL pbaru(ip1jmp1,llm), pbarv(ip1jm,llm)  
   REAL masse(ip1jmp1,llm), teta(ip1jmp1,llm), phi(ip1jmp1,llm)  
15    REAL phis(ip1jmp1)    REAL phis(ip1jmp1)
16      REAL, intent(in):: time_step
17      INTEGER, INTENT (IN) :: itau
18    
19    REAL pbaruc(ip1jmp1,llm), pbarvc(ip1jm,llm)    ! Variables local to the procedure:
   REAL massem(ip1jmp1,llm), tetac(ip1jmp1,llm), phic(ip1jmp1,llm)  
   
   REAL pbarug(ip1jmp1,llm), pbarvg(iip1,jjm,llm), wg(ip1jmp1,llm)  
20    
21    REAL pbarvst(iip1,jjp1,llm), zistdyn    REAL, SAVE:: pbaruc(ip1jmp1, llm), pbarvc(ip1jm, llm)
22    REAL dtcum    REAL, SAVE:: massem(ip1jmp1, llm)
23      real, SAVE:: tetac(ip1jmp1, llm), phic(ip1jmp1, llm)
24    
25    INTEGER iadvtr, ndex(1)    REAL pbarug(ip1jmp1, llm), pbarvg(iip1, jjm, llm), wg(ip1jmp1, llm)
26    INTEGER nscal    INTEGER:: iadvtr = 0
27    REAL tst(1), ist(1), istp(1)    REAL tst(1), ist(1), istp(1)
28    INTEGER ij, l, irec, i, j    INTEGER ij, l
29    INTEGER, INTENT (IN) :: itau    INTEGER, save:: fluxid, fluxvid
30    INTEGER fluxid, fluxvid, fluxdid    integer fluxdid
31      LOGICAL:: first = .TRUE.
   SAVE iadvtr, massem, pbaruc, pbarvc, irec  
   SAVE phic, tetac  
   LOGICAL first  
   SAVE first  
   DATA first/ .TRUE./  
   DATA iadvtr/0/  
32    
33    !-------------------------------------------------------------    !-------------------------------------------------------------
34    
35    IF (first) THEN    IF (first) THEN
36       CALL initfluxsto(time_step,istdyn*time_step,istdyn*time_step,nqmx, &       CALL initfluxsto(time_step, istdyn*time_step, istdyn*time_step, nqmx, &
37            fluxid,fluxvid,fluxdid)            fluxid, fluxvid, fluxdid)
38         CALL histwrite(fluxid, 'phis', 1, phis)
39       ndex(1) = 0       CALL histwrite(fluxid, 'aire', 1, aire)
      CALL histwrite(fluxid,'phis',1,phis)  
      CALL histwrite(fluxid,'aire',1,aire)  
   
      ndex(1) = 0  
      nscal = 1  
40       tst(1) = time_step       tst(1) = time_step
41       CALL histwrite(fluxdid,'dtvr',1,tst)       CALL histwrite(fluxdid, 'dtvr', 1, tst)
42       ist(1) = istdyn       ist(1) = istdyn
43       CALL histwrite(fluxdid,'istdyn',1,ist)       CALL histwrite(fluxdid, 'istdyn', 1, ist)
44       istp(1) = istphy       istp(1) = istphy
45       CALL histwrite(fluxdid,'istphy',1,istp)       CALL histwrite(fluxdid, 'istphy', 1, istp)
46    
47       first = .FALSE.       first = .FALSE.
48    END IF    END IF
49    
50      IF (itau == 0) THEN
51    IF (iadvtr==0) THEN       CALL initial0(ijp1llm, phic)
52       CALL initial0(ijp1llm,phic)       CALL initial0(ijp1llm, tetac)
53       CALL initial0(ijp1llm,tetac)       CALL initial0(ijp1llm, pbaruc)
54       CALL initial0(ijp1llm,pbaruc)       CALL initial0(ijmllm, pbarvc)
      CALL initial0(ijmllm,pbarvc)  
55    END IF    END IF
56    
57    !   accumulation des flux de masse horizontaux    !   accumulation des flux de masse horizontaux
58    DO l = 1, llm    DO l = 1, llm
59       DO ij = 1, ip1jmp1       DO ij = 1, ip1jmp1
60          pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)          pbaruc(ij, l) = pbaruc(ij, l) + pbaru(ij, l)
61          tetac(ij,l) = tetac(ij,l) + teta(ij,l)          tetac(ij, l) = tetac(ij, l) + teta(ij, l)
62          phic(ij,l) = phic(ij,l) + phi(ij,l)          phic(ij, l) = phic(ij, l) + phi(ij, l)
63       END DO       END DO
64       DO ij = 1, ip1jm       DO ij = 1, ip1jm
65          pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)          pbarvc(ij, l) = pbarvc(ij, l) + pbarv(ij, l)
66       END DO       END DO
67    END DO    END DO
68    
69    !   selection de la masse instantannee des mailles avant le transport.    !   selection de la masse instantannee des mailles avant le transport.
70    IF (iadvtr==0) THEN    IF (itau == 0) THEN
71       CALL scopy(ip1jmp1*llm,masse,1,massem,1)       CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)
72    END IF    END IF
73    
74    iadvtr = iadvtr + 1    iadvtr = iadvtr + 1
75    
   
76    !   Test pour savoir si on advecte a ce pas de temps    !   Test pour savoir si on advecte a ce pas de temps
77    IF (iadvtr==istdyn) THEN    IF (iadvtr == istdyn) THEN
78       !    normalisation       !    normalisation
79       DO l = 1, llm       DO l = 1, llm
80          DO ij = 1, ip1jmp1          DO ij = 1, ip1jmp1
81             pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)             pbaruc(ij, l) = pbaruc(ij, l)/float(istdyn)
82             tetac(ij,l) = tetac(ij,l)/float(istdyn)             tetac(ij, l) = tetac(ij, l)/float(istdyn)
83             phic(ij,l) = phic(ij,l)/float(istdyn)             phic(ij, l) = phic(ij, l)/float(istdyn)
84          END DO          END DO
85          DO ij = 1, ip1jm          DO ij = 1, ip1jm
86             pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)             pbarvc(ij, l) = pbarvc(ij, l)/float(istdyn)
87          END DO          END DO
88       END DO       END DO
89    
# Line 109  SUBROUTINE fluxstokenc(pbaru,pbarv,masse Line 91  SUBROUTINE fluxstokenc(pbaru,pbarv,masse
91       !     1. calcul de w       !     1. calcul de w
92       !     2. groupement des mailles pres du pole.       !     2. groupement des mailles pres du pole.
93    
94       CALL groupe(massem,pbaruc,pbarvc,pbarug,pbarvg,wg)       CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)
   
      DO l = 1, llm  
         DO j = 1, jjm  
            DO i = 1, iip1  
               pbarvst(i,j,l) = pbarvg(i,j,l)  
            END DO  
         END DO  
         DO i = 1, iip1  
            pbarvst(i,jjp1,l) = 0.  
         END DO  
      END DO  
   
95       iadvtr = 0       iadvtr = 0
96       PRINT *, 'ITAU auqel on stoke les fluxmasses', itau       PRINT *, 'ITAU auqel on stoke les fluxmasses', itau
97    
98       CALL histwrite(fluxid,'masse',itau,massem)       CALL histwrite(fluxid, 'masse', itau, massem)
99       CALL histwrite(fluxid,'pbaru',itau,pbarug)       CALL histwrite(fluxid, 'pbaru', itau, pbarug)
100       CALL histwrite(fluxvid,'pbarv',itau,pbarvg)       CALL histwrite(fluxvid, 'pbarv', itau, pbarvg)
101       CALL histwrite(fluxid,'w',itau,wg)       CALL histwrite(fluxid, 'w', itau, wg)
102       CALL histwrite(fluxid,'teta',itau,tetac)       CALL histwrite(fluxid, 'teta', itau, tetac)
103       CALL histwrite(fluxid,'phi',itau,phic)       CALL histwrite(fluxid, 'phi', itau, phic)
104    END IF ! if iadvtr.EQ.istdyn                                          END IF                                
105    
106  END SUBROUTINE fluxstokenc  END SUBROUTINE fluxstokenc
Legend:
Removed from v.30  
changed lines
  Added in v.31
  ViewVC Help
Powered by ViewVC 1.1.21